luv

Workshop wiki

tape.lisp

luvcraft/tape.lisp

system luvcraft/core · 43 definitions · on GitHub

The tape: a film reel that fetches a YouTube video and becomes a film.

A tape is a placeable block. Focusing one asks for a YouTube code (the question itself is a McCLIM panel supplied by LUVCRAFT/CLIM through open-tape-prompt); answering starts yt-dlp in the background and hangs a progress orb over the block -- a sphere of bright motes that fills from the bottom as the download comes in. When the file lands the tape is replaced by a FILM: a per-instance block kind carrying the video's metadata and the path of the media, which the player picks up into the inventory by hitting it, and can put down again anywhere.

The download job is an overlay that draws nothing: it hangs on the session so refresh-luvcraft-overlay polls the process once per frame, on the render thread, which is where the world may be edited and particles emitted.

in-package#:luvcraft

--------------------------------------------------------------------- Where films live and how yt-dlp is found.

defunluvcraft-films-directory

The directory downloaded films are kept in, beside the saved worlds.

merge-pathnames#P"luvcraft/films/"
let
data-home
uiop:getenv"XDG_DATA_HOME"
ifdata-home
uiop:ensure-directory-pathname
pathnamedata-home
merge-pathnames#P".local/share/"
user-homedir-pathname
defunyt-dlp-program

The yt-dlp executable: the one Nix names in luv_YT_DLP, else whichever is on the PATH.

let
named
uiop:getenv"LUV_YT_DLP"
if
andnamed
probe-filenamed
named"yt-dlp"
defparameter*tape-format*

b[ext=mp4][vcodec^=avc1][height<=720]/bv*[ext=mp4][vcodec^=avc1][height<=720]+ba[ext=m4a]/b[ext=mp4]/b

The yt-dlp format selector for a tape: an H.264 MP4 no taller than 720 lines, whole if the site has one, merged from picture and sound if not, whatever it has otherwise. A whole file first because it is what the plainest player clients hand out without a fight; see *TAPE-PLAYER-CLIENTS*.

defparameter*tape-player-clients*

mweb,android,default

Which YouTube player clients yt-dlp asks, in order of precedence.

The default client's segmented formats answer 403 as often as not this season, and yt-dlp does not fall back once a download has begun; the mobile web and Android clients hand out a plain progressive MP4 that arrives. A knob rather than a constant, since this is YouTube's weather, not ours.

defunyoutube-video-id
text

Extract the eleven-character video id from text, which may be a bare code or any of the usual YouTube URLs; NIL when there is none.

let*
text
string-trim'
#\Space#\Tab#\Newline#\Return
text
id-char-p
lambda
c
or
alphanumericpc
findc"-_"
flet
id-at
start
let
end
or
position-if-notid-char-ptext:startstart
lengthtext
when
=
-endstart
11
subseqtextstartend
cond
and
=
lengthtext
11
everyid-char-ptext
text
search"v="text
id-at
+2
search"v="text
search"youtu.be/"text
id-at
+9
search"youtu.be/"text
search"/shorts/"text
id-at
+8
search"/shorts/"text
search"/embed/"text
id-at
+7
search"/embed/"text
tnil

--------------------------------------------------------------------- The film: a block kind per video.

defclassfilm-block-kind
video-id:initarg:video-id:readerfilm-video-id
title:initarg:title:initformnil:accessorfilm-title
uploader:initarg:uploader:initformnil:accessorfilm-uploader
duration:initarg:duration:initformnil:accessorfilm-duration:documentation"Seconds, or NIL when the site did not say."
upload-date:initarg:upload-date:initformnil:accessorfilm-upload-date:documentation"YYYYMMDD as a string, or NIL."
pathname:initarg:pathname:initformnil:accessorfilm-pathname:documentation"Where the media is, or NIL if it never landed."
:documentation

One downloaded video as a thing in the world and in the bag.

Every film shares the name :FILM and the reel's tiles; what differs is the video, so a film is its own block kind rather than one entry in the palette, and the world's palette-by-identity storage keeps them apart for free.

defvar*films*
make-hash-table:test'equal

Every film this image knows, by video id, so a saved world and a saved bag that name the same video get the same object back.

defunensure-film
video-id&keytitleuploaderdurationupload-datepathname

Return the film for video-id, making it or filling in what is now known.

check-typevideo-idstring
let
film
gethashvideo-id*films*
unlessfilm
setffilm
make-instance'film-block-kind:name:film:video-idvideo-id:face-tiles'
:front:film-flange:back:film-flange:top:reel-rim:bottom:reel-rim:left:reel-rim:right:reel-rim
:categories'
:building
:display-color'
0.620.550.42
:placeable-pnil
gethashvideo-id*films*
film
whentitle
setf
film-titlefilm
title
whenuploader
setf
film-uploaderfilm
uploader
whenduration
setf
film-durationfilm
duration
whenupload-date
setf
film-upload-datefilm
upload-date
whenpathname
setf
film-pathnamefilm
pathname
film
defunfilm-label
film

A short line naming film for a title bar or a bag.

or
film-titlefilm
film-video-idfilm
defmethodblock-save-description
list:film:video-id
film-video-idfilm
:title
film-titlefilm
:uploader
film-uploaderfilm
:duration
film-durationfilm
:upload-date
film-upload-datefilm
:pathname
and
film-pathnamefilm
namestring
film-pathnamefilm
defmethodrestore-block-save-description
kind
eql:film
description
let
video-id
description-valuedescription:video-id"film value"
unless
stringpvideo-id
invalid-luvcraft-save"A film's video id must be a string, not ~S."video-id
flet
field
key
description-valuedescriptionkey"film value":optionalt:defaultnil
ensure-filmvideo-id:title
field:title
:uploader
field:uploader
:duration
field:duration
:upload-date
field:upload-date
:pathname
let
name
field:pathname
andname
pathnamename

--------------------------------------------------------------------- The download: yt-dlp in the background, read by one thread.

defclasstape-download
session:initarg:session:readertape-download-session
x:initarg:x:readertape-download-x
y:initarg:y:readertape-download-y
z:initarg:z:readertape-download-z
video-id:initarg:video-id:readertape-download-video-id
process:initformnil:accessortape-download-process
reader:initformnil:accessortape-download-reader

Written by the reader thread, read by the render thread: each is one word or one fresh object, never a structure edited in place.

fraction:initform0.0:accessortape-download-fraction:documentation"0..1 of the current stream."
streams-done:initform0:accessortape-download-streams-done
metadata:initformnil:accessortape-download-metadata:documentation"A plist of the video's facts once printed."
file:initformnil:accessortape-download-file:documentation"The final media pathname once yt-dlp has moved it."
log:initformnil:accessortape-download-log:documentation"The last few lines yt-dlp said, newest first."
finished-p:initformnil:accessortape-download-finished-p
age:initform0.0:accessortape-download-age
spin:initform0.0:accessortape-download-spin
last-refresh:initformnil:accessortape-download-last-refresh:documentation"Internal real time of the last frame."
:documentation

One yt-dlp run for the tape at X,Y,Z, hung on SESSION as an overlay.

defmethodluvcraft-overlay-stage

Drawn by no pass: the orb is particles, and there is nothing else.

:none
defuntape-download-progress
download

How much of the whole download is done, 0..1.

yt-dlp fetches sound and picture as two streams for most videos and then merges them, so a stream's own percentage runs to a hundred twice. Until the second one starts we assume there will be two; a single-stream video simply arrives early.

let
done
tape-download-streams-donedownload
fraction
tape-download-fractiondownload
min1.0
/
+donefraction
max2
1+done
defunparse-yt-dlp-line
downloadline

Fold one line of yt-dlp's stdout into download's progress and facts.

let
line
string-right-trim'
#\Return#\Newline
line
cond
uiop:string-prefix-p"META"line
destructuring-bind
&optionalidtitleuploaderdurationdate
rest
uiop:split-stringline:separator'
#\Tab
declare
ignoreid
setf
tape-download-metadatadownload
list:titletitle:uploaderuploader:duration
ignore-errors
parse-integerduration
:upload-datedate
uiop:string-prefix-p"FILE"line
let
name
second
uiop:split-stringline:separator'
#\Tab
when
andname
plusp
lengthname
setf
tape-download-filedownload
pathnamename
uiop:string-prefix-p"[download]"line
let*
percent-end
position#\%line
percent-start
andpercent-end
position#\Spaceline:endpercent-end:from-endt
when
andpercent-startpercent-end
let
percent
ignore-errors
let
*read-default-float-format*'single-float
read-from-string
subseqline
1+percent-start
percent-end
when
realppercent
let
fraction
/
coercepercent'single-float
100.0

A stream's summary line reads "100% of ... in ..." -- that is the stream done, and the next starts at zero.

if
search" in "line
setf
tape-download-fractiondownload
0.0
tape-download-streams-donedownload
1+
tape-download-streams-donedownload
setf
tape-download-fractiondownload
fraction
setf
tape-download-logdownload
consline
subseq
tape-download-logdownload
0
min8
length
tape-download-logdownload
download
defunstart-tape-download
download

Run yt-dlp for download and start the thread that listens to it.

let*
video-id
tape-download-video-iddownload
process
progn
ensure-directories-existdirectory
sb-ext:run-program
list"--no-playlist""--no-simulate""--progress""--newline""--no-colors""--extractor-args"
formatnil"youtube:player_client=~A"*tape-player-clients*
"-f"*tape-format*"--merge-output-format""mp4""-o"
namestring
merge-pathnames"%(id)s.%(ext)s"directory
"--print"
formatnil"pre_process:META~C%(id)s~C%(title)s~C%(uploader)s~C%(duration)s~C%(upload_date)s"#\Tab#\Tab#\Tab#\Tab#\Tab
"--print"
formatnil"after_move:FILE~C%(filepath)s"#\Tab
formatnil"https://www.youtube.com/watch?v=~A"video-id
:searcht:inputnil:output:stream:error:output:waitnil
setf
tape-download-processdownload
process
tape-download-readerdownload
sb-thread:make-thread
lambda
unwind-protect
with-open-stream
output
sb-ext:process-outputprocess
loopforline=
read-lineoutputnilnil
whilelinedo
parse-yt-dlp-linedownloadline
sb-ext:process-waitprocess
setf
tape-download-finished-pdownload
t
:name
formatnil"tape ~A"video-id
download
defuntape-download-succeeded-p
download
let
process
tape-download-processdownload
file
tape-download-filedownload
andfile
eql0
sb-ext:process-exit-codeprocess
probe-filefile

--------------------------------------------------------------------- The orb: motes on a sphere over the tape, filled to the progress.

defparameter*tape-orb-height*1.55"How far above the tape's floor the orb's centre floats."
defparameter*tape-orb-radius*0.28
defparameter*tape-orb-motes-per-second*600"How thickly the orb is sown; each mote lasts a fraction of a second."
defunemit-tape-orb
downloadseconds

Sow this frame's motes over download's tape: a slowly turning shell, lit from the bottom up as far as the progress has come, with a faint fountain of sparks off the top.

let*
session
tape-download-sessiondownload
system
luvcraft-session-particle-systemsession
progress
age
incf
tape-download-agedownload
coerceseconds'single-float
spin
incf
tape-download-spindownload
*0.9
coerceseconds'single-float
cx
+
tape-download-xdownload
0.5
cy
+
tape-download-ydownload
*tape-orb-height*
*0.05
sin
*2.0age
cz
+
tape-download-zdownload
0.5
dotimes
indexcount
let*
u
fractional-part
+
*index0.618034
*7.13age
v
fractional-part
+
*index0.414214
*3.71age

Uniform on the sphere: height from the cosine, then a ring.

height
-
*2.0v
1.0
angle
+spin
*2.0piu
lit-p
<=
*0.5
+progress0.02

A few sparks leave the crown, whichever way round they were.

spark-p
cond
lit-p
spark-p
emit-block-motesystem*orb-mote-block*:size0.02:lifetime0.5:velocity-x:velocity-y0.7:velocity-z
download
defunpop-tape-orb
download

The orb bursts: one last spray of motes going every way.

let*
session
tape-download-sessiondownload
system
luvcraft-session-particle-systemsession
cx
+
tape-download-xdownload
0.5
cy
+
tape-download-ydownload
*tape-orb-height*
cz
+
tape-download-zdownload
0.5
dotimes
index60
let*
u
fractional-part
*index0.618034
v
fractional-part
*index0.414214
height
-
*2.0v
1.0
angle
*2.0piu
speed2.5
emit-block-motesystem*orb-mote-block*cxcycz:velocity-x
*speedring
:velocity-y
*speedheight
:velocity-z
*speedring
:size0.05:lifetime0.6:gravity3.0
download

--------------------------------------------------------------------- The job on the session.

defunfind-tape-download
sessionxyz
find-if
lambda
overlay
and
typepoverlay'tape-download
=
tape-download-xoverlay
x
=
tape-download-yoverlay
y
=
tape-download-zoverlay
z
luvcraft-session-overlayssession
defunbegin-tape-download
sessionxyzvideo-id

Start fetching video-id for the tape at X,Y,Z and hang the job on session.

check-typevideo-idstring
or
let
download
make-instance'tape-download:sessionsession:xx:yy:zz:video-idvideo-id
luv:log-event:luvcraft"tape at ~D,~D,~D fetching ~A"xyzvideo-id
add-luvcraft-overlaysessiondownload
defunfinish-tape-download
download

The process is over: turn the tape into its film, or leave it a tape.

let*
session
tape-download-sessiondownload
world
luvcraft-session-worldsession
x
tape-download-xdownload
y
tape-download-ydownload
z
tape-download-zdownload
cond
let
film
apply#'ensure-film
tape-download-video-iddownload
:pathname
tape-download-filedownload
tape-download-metadatadownload
luv:log-event:luvcraft"tape at ~D,~D,~D is now the film ~S"xyz
pop-tape-orbdownload

The tape may have been dug out while it fetched; then the film goes straight into the bag instead of into a hole.

if
edit-block-atfilmworldxyz
add-block-to-inventory
luvcraft-session-inventorysession
film1
t
luv:log-event:luvcraft"tape at ~D,~D,~D failed to fetch ~A:~{~% ~A~}"xyz
tape-download-video-iddownload
reverse
tape-download-logdownload
download
defmethodrefresh-luvcraft-overlay
session
declare
ignoresession
let*
now
get-internal-real-time
last
shiftf
tape-download-last-refreshdownload
now
seconds
iflast
min0.1
/
-nowlast
internal-time-units-per-second
0.0
if
tape-download-finished-pdownload
emit-tape-orbdownloadseconds
defmethodrelease-luvcraft-overlay
let
process
tape-download-processdownload
when
andprocess
sb-ext:process-alive-pprocess
sb-ext:process-killprocess15
download

--------------------------------------------------------------------- Focusing a tape asks the question.

defgenericopen-tape-prompt
sessionxyz
:documentation

Show session the question a tape at X,Y,Z asks -- which YouTube code? -- and return the focus that is asking it, or NIL when no presentation system can. LUVCRAFT/CLIM supplies the panel; the answer comes back through begin-tape-download.

:method
sessionxyz
declare
ignoresessionxyz
nil
defmethodactivate-luvcraft-target
let*
coordinate
block-ray-hit-coordinatehit
x
world-coordinate-xcoordinate
y
world-coordinate-ycoordinate
z
world-coordinate-zcoordinate

A tape already fetching has been asked; the orb is its answer.

unless

--------------------------------------------------------------------- A film beside a wall plays on it.

Put a film down touching a terminal wall and the wall shows it; pick the film up again and the wall goes back to what it was. The film does not sit on the wall's face -- that would cover the screen -- but beside it: on the floor in front, on the wall's edge, anywhere one of its six neighbours is a terminal block with an exposed face.

defunfilm-wall-beside
worldxyz&keyviewer

Return the largest exposed terminal surface touching X,Y,Z, and the face it was found through, or NIL when no wall stands beside the block.

viewer is a point (the player's eye); of two faces of one wall the side turned toward it wins, so a film set down before a wall lights the side the player is looking at rather than the one behind.

let
bestnil
best-facenil
best-area0
dolist
direction*block-faces*
let*
neighbor
block-face-neighbordirection
nx
+x
voxel-direction-dxneighbor
ny
+y
voxel-direction-dyneighbor
nz
+z
voxel-direction-dzneighbor
when
eq
world-block-atworldnxnynz
*terminal-block*

Every face of that block but the one looking at us -- which we cover -- and the one looking away, which is the wall's back.

dolist
let
normal
block-face-neighborface
unless
and
=
voxel-direction-dxnormal
-
voxel-direction-dxneighbor
=
voxel-direction-dynormal
-
voxel-direction-dyneighbor
=
voxel-direction-dznormal
-
voxel-direction-dzneighbor
let
surface
find-terminal-surfaceworldnxnynz
block-face-nameface
whensurface
let
area
+
*2
terminal-surface-widthsurface
terminal-surface-heightsurface
if
andviewer
plusp
+
*
voxel-direction-dxnormal
-
vec3-xviewer
nx0.5
*
voxel-direction-dynormal
-
vec3-yviewer
ny0.5
*
voxel-direction-dznormal
-
vec3-zviewer
nz0.5
10
when
>areabest-area
setfbestsurfacebest-face
block-face-nameface
best-areaarea
valuesbestbest-face
defunterminal-surface-same-wall-p
ab
and
eq
terminal-surface-facea
terminal-surface-faceb
equalp
terminal-surface-origina
terminal-surface-originb
=
terminal-surface-widtha
terminal-surface-widthb
=
terminal-surface-heighta
terminal-surface-heightb
defunfind-terminal-display-on
sessionsurface

The display session already has on surface's wall, if any.

find-if
lambda
overlay
and
typepoverlay'terminal-display
typep
terminal-display-surfaceoverlay
'terminal-surface
terminal-surface-same-wall-p
terminal-display-surfaceoverlay
surface
luvcraft-session-overlayssession
defvar*film-projections*
make-hash-table:test'equal

Which display each placed film lit, by (X Y Z): the display, and whether the film opened it -- in which case taking the film away closes it too.

defunshow-film-beside
sessionfilmxyz

Play film, which stands at X,Y,Z, on the wall beside it, if there is one. Return the display it plays on, or NIL.

multiple-value-bind
surfaceface
film-wall-beside
luvcraft-session-worldsession
xyz:viewer
camera-position
luvcraft-session-camerasession
when
andsurface
film-pathnamefilm
probe-file
film-pathnamefilm
let*
existing
display
orexisting
open-terminal-displaysession
world-coordinate-x
terminal-surface-originsurface
world-coordinate-y
terminal-surface-originsurface
world-coordinate-z
terminal-surface-originsurface
face:fixture""
play-terminal-display-filmdisplay
film-pathnamefilm
:hardware:auto
setf
gethash
listxyz
*film-projections*
consdisplay
nullexisting
luv:log-event:luvcraft"film ~S plays on the wall beside ~D,~D,~D"xyz
display
defunhide-film-beside
sessionxyz

The film at X,Y,Z is gone: stop what it was showing.

let
projection
gethash
listxyz
*film-projections*
whenprojection
remhash
listxyz
*film-projections*
destructuring-bind
display.opened-p
projection
when
memberdisplay
luvcraft-session-overlayssession
ifopened-p
change-terminal-display-modedisplaysession:shell
defmethodluvcraft-block-placed
sessionxyz
show-film-besidesessionfilmxyz

--------------------------------------------------------------------- After a restart, the films already standing in the world light their walls again -- once the ground under them has streamed in.

defclassfilm-relighting
pending:initarg:pending:accessorfilm-relighting-pending:documentation"The (X Y Z) of every film not yet looked at."
:documentation

A drawless overlay that shows each of the world's films on its wall as soon as its cell is resident, then takes itself down.

defunworld-film-coordinates
world

The (X Y Z) of every film written into world's authored edits.

let
source
block-world-sourceworld
when
loopforcoordinatebeingthehash-keysof
block-edit-overlay-entries
little-world-source-editssource
using
hash-valueblock
when
typepblock'film-block-kind
collectcoordinate
defunrelight-world-films
session

Arrange for session's world's films to play on their walls again.

let
pending
world-film-coordinates
luvcraft-session-worldsession
whenpending
add-luvcraft-overlaysession
make-instance'film-relighting:pendingpending
defmethodrefresh-luvcraft-overlay
session
let
world
luvcraft-session-worldsession
setf
film-relighting-pendingjob
remove-if
lambda
coordinate
destructuring-bind
xyz
coordinate
multiple-value-bind
blockresidency
when
eqresidency:resident
when
typepblock'film-block-kind
show-film-besidesessionblockxyz
t
film-relighting-pendingjob
unless
film-relighting-pendingjob