luv

Workshop wiki

mirror.lisp

luvcraft/mirror.lisp

system luvcraft/core · 15 definitions · on GitHub

A luvcraft that draws for another luvcraft.

The experiment: the shipped executable is a boot core -- a Lisp with the whole game loaded and nothing yet asked of the GPU. A playing game can spawn one as a child, hand it the integer name of an IOSurface over the child's own stdin, and the child renders its own hidden game into that surface while the parent samples the very same pixels as a texture. No ports, no shared memory ceremony: a pipe carrying one number each way.

The protocol is lockstep and tiny. Child writes "hello SCREEN" (the wall it wants to appear on, or "-"). Parent writes "size W H" (points); child opens its hidden game and answers "extent W H" (pixels). Parent creates a ring of surfaces that size and writes "surfaces ID ID ID"; child wraps each and answers "ready". Parent writes "frame K", child renders one frame into slot K, waits for the GPU, and answers "done K". Parent writes "quit" or closes the pipe; child stops. The ring is what keeps the picture from tearing: the parent only ever asks for a slot it is not showing and was not showing a frame ago.

The lines travel over whichever two-way stream the two ends share: the pipes of a child the parent spawned itself, or a Unix socket the child connected to because luvcraft_PARENT_SOCKET was in its environment (see portal-server.lisp).

in-package#:luvcraft

The child: render into a surface somebody else named.

defunattach-luvcraft-frame-mirror
sessionsurface

Return an adopted texture over the IOSurface surface, sized like session's frame, fit to be session's frame mirror. The caller destroys it.

#-darwin
declare
ignoresessionsurface
#-darwin
error"Frame mirrors need IOSurface, which is Darwin only."
#+darwin (let* ((device (luvcraft-session-device session)) (context (luvcraft-session-context session)) (format (canvas-format context)) (extent (canvas-extent context)) (width (luv.metal:iosurface-width surface)) (height (luv.metal:iosurface-height surface))) (unless (and (= width (first extent)) (= height (second extent))) (error "The mirror surface is ~Dx~D but the game frame is ~Dx~D." width height (first extent) (second extent))) (let* ((native (luv.metal:new-metal-texture-for-iosurface (luv::metal-native-object device) surface (luv::metal-resource-pixel-format format nil) (logior luv.metal:+texture-usage-shader-read+ luv.metal:+texture-usage-render-target+) :label "luvcraft frame mirror")) ;; The +1 from NEW is the owner reference DESTROY will CFRelease. (mirror (adopt-native-texture device native (luv.objective-c:objective-c-pointer native) (make-texture-descriptor :label "luvcraft frame mirror" :size (list width height) :dimensions :2d :format format :usage '(:copy-dst :texture-binding))))) mirror))
defunserve-luvcraft-mirror
&key
input*standard-input*
output*standard-output*
screen"-"
provider

Be the child: greet the parent on output naming screen, open a hidden game of the size the parent answers with on input, tell it the frame's pixel extent, and from then on render into whatever surfaces input names.

flet
say
control&restarguments
apply#'formatoutputcontrolarguments
terprioutput
finish-outputoutput
hear
let
line
read-lineinputnilnil
andline
uiop:split-string
string-trim" "line
say"hello ~A"
if
plusp
lengthscreen
screen"-"
let*
message
hear
width
and
equal
firstmessage
"size"
parse-integer
secondmessage
:junk-allowedt
height
andwidth
parse-integer
thirdmessage
:junk-allowedt
unlessheight
error"Expected \"size W H\" from the parent, got ~S."message
let
surfacesnil
sessionnil
mirrorsnil
unwind-protect
progn
setfsession
start-luvcraft:title"luvcraft mirror child":widthwidth:heightheight:frames-per-secondnil:visible-pnil:providerprovider

The window is in points; the frame is in pixels, and the surfaces have to be the frame's size, so the parent learns the pixel extent from us and creates the ring after.

let
extent
canvas-extent
luvcraft-session-contextsession
say"extent ~D ~D"
firstextent
secondextent
let
message
hear
unless
and
equal
firstmessage
"surfaces"
restmessage
error"Expected \"surfaces ID...\", got ~S."message
setfsurfaces
map'vector
lambda
word
let
id
parse-integerword:junk-allowedt
or
error"No IOSurface is named ~A."word
restmessage
setfmirrors
map'vector
lambda
surface
surfaces
say"ready"
loopformessage=
hear
while
andmessage
not
equal
firstmessage
"quit"
do
cond
equal
firstmessage
"frame"
let
slot
parse-integer
or
secondmessage
"0"
:junk-allowedt
unless
andslot
<-1slot
lengthmirrors
error"No ring slot ~S."
secondmessage
setf
luvcraft-session-frame-mirrorsession
arefmirrorsslot
render-luvcraft-framesession
/
get-internal-real-time
floatinternal-time-units-per-second1d0
submitted-work-done
device-queue
luvcraft-session-devicesession
say"done ~D"slot
t
say"what ~{~A~^ ~}"message
whensession
setf
luvcraft-session-frame-mirrorsession
nil
whenmirrors
mapnil#'destroymirrors
whensurfaces

The parent: a child on the far end of a stream and the surfaces it draws into.

defclassluvcraft-mirror
stream:initarg:stream:readerluvcraft-mirror-stream

Only when this process spawned the child itself.

process:initarg:process:initformnil:readerluvcraft-mirror-process

What the child asked to appear on, from its hello.

screen:initform"-":accessorluvcraft-mirror-screen
surfaces:initform
:accessorluvcraft-mirror-surfaces
width:initformnil:accessorluvcraft-mirror-width
height:initformnil:accessorluvcraft-mirror-height
frames:initform0:accessorluvcraft-mirror-frames

The slot the child most recently finished, or NIL before the first.

completed-slot:initformnil:accessorluvcraft-mirror-completed-slot
:documentation

A child luvcraft rendering into a ring of IOSurfaces this process owns. width and height are the surfaces', in pixels.

defunluvcraft-mirror-surface
mirror&optionalslot

Surface slot of mirror's ring; with no slot, the last completed one.

aref
luvcraft-mirror-surfacesmirror
orslot
luvcraft-mirror-completed-slotmirror
0
defunluvcraft-mirror-slot-count
mirror
length
luvcraft-mirror-surfacesmirror
defunluvcraft-mirror-executable
let
path
merge-pathnames"build/luvcraft"
asdf:system-source-directory"luvcraft"
unless
probe-filepath
error"There is no ~A to spawn; run make luvcraft first."path
path
defuntell-luvcraft-mirror
mirrorcontrol&restarguments
let
stream
luvcraft-mirror-streammirror
apply#'formatstreamcontrolarguments
terpristream
finish-outputstream
defunhear-luvcraft-mirror
mirrorword

Read the child's lines until one starts with word; NIL if it never does. A spawned child's stdout also carries the ordinary startup chatter of the game.

loopforline=
read-line
luvcraft-mirror-streammirror
nilnil
whilelinewhen
uiop:string-prefix-pwordline
returnline
defunnegotiate-luvcraft-mirror
mirror&key
slots3

Take mirror from a fresh child's hello to a ready ring: hear the hello, name a width x height window (points), hear the pixel extent, make slots surfaces that size, hand their IDs over, and hear ready. Returns mirror.

handler-bind
error
lambda
condition
declare
ignorecondition
let
hello
unlesshello
error"The mirror child never said hello."
setf
luvcraft-mirror-screenmirror
or
second
uiop:split-stringhello
"-"
let
extent
hear-luvcraft-mirrormirror"extent"
unlessextent
error"The mirror child never reported its frame extent."
destructuring-bind
wordpixel-widthpixel-height
uiop:split-stringextent
declare
ignoreword
setf
luvcraft-mirror-widthmirror
parse-integerpixel-width
luvcraft-mirror-heightmirror
parse-integerpixel-height
luvcraft-mirror-surfacesmirror
coerce
looprepeatslotscollect
luv.metal:create-iosurface
luvcraft-mirror-widthmirror
luvcraft-mirror-heightmirror
'vector
tell-luvcraft-mirrormirror"surfaces~{ ~D~}"
map'list#'luv.metal:iosurface-id
luvcraft-mirror-surfacesmirror
unless
error"The mirror child did not become ready."
mirror
defunspawn-luvcraft-mirror
&key
slots3
executable

Spawn a child game in a hidden width x height window (in points) over pipes, give it a ring of slots surfaces the size of its pixel frame, and return the mirror once it is drawing. Its stderr lands in build/luvcraft-mirror.log.

let*
process
sb-ext:run-program
namestring
'
"--serve-surface"
:input:stream:output:stream:waitnil:error
namestring
merge-pathnames"build/luvcraft-mirror.log"
asdf:system-source-directory"luvcraft"
:if-error-exists:supersede
mirror
make-instance'luvcraft-mirror:processprocess:stream
make-two-way-stream
sb-ext:process-outputprocess
sb-ext:process-inputprocess
negotiate-luvcraft-mirrormirror:widthwidth:heightheight:slotsslots
defunrequest-luvcraft-mirror-frame
mirror&optionalslot

Ask the child for one frame into slot (default: the slot after the last completed one) and return the slot once its pixels are in the surface.

let
slot
orslot
mod
1+
or
luvcraft-mirror-completed-slotmirror
-1
tell-luvcraft-mirrormirror"frame ~D"slot
let
answer
unlessanswer
error"The mirror child did not finish a frame; see build/luvcraft-mirror.log."
incf
luvcraft-mirror-framesmirror
setf
luvcraft-mirror-completed-slotmirror
slot
slot
defunstop-luvcraft-mirror
mirror

Tell the child to quit, drop the stream, and release the ring.

ignore-errors
let
process
luvcraft-mirror-processmirror
whenprocess
when
sb-ext:process-alive-pprocess
sb-ext:process-waitprocess
sb-ext:process-closeprocess
ignore-errors
close
luvcraft-mirror-streammirror
mapnil#'luv.metal:release-iosurface
luvcraft-mirror-surfacesmirror
setf
luvcraft-mirror-surfacesmirror
values
defunluvcraft-mirror-pixel
mirrorxy

The child's pixel at X, Y as (B G R A) bytes.

defunluvcraft-mirror-pixels
mirror

The child's whole frame as tightly packed BGRA bytes, copied out of the surface.

let*
width
luvcraft-mirror-widthmirror
height
luvcraft-mirror-heightmirror
pixels
make-array:element-type'
unsigned-byte8
luv.metal:with-locked-iosurface
surface:read-onlyt
let
base
luv.metal:iosurface-base-addresssurface
stride
luv.metal:iosurface-bytes-per-rowsurface
dotimes
dotimes
setf
arefpixels
cffi:mem-refbase:uint8
+
*ystride
i
pixels
defunsave-luvcraft-mirror-png
mirrorpathname

Write the child's current frame to pathname.

ensure-directories-existpathname
write-rgba-pngpathname
luvcraft-mirror-widthmirror
luvcraft-mirror-heightmirror
:bgra8-unorm