luv

Workshop wiki

metabar.lisp

mcclim/metabar.lisp

system luv/mcclim · 104 definitions · on GitHub

The metabar is a shared, retained application instrument: a drawer of grouped live controls and actions which an application may attach to its own render and input lifecycle. This file owns the semantic UI, not any particular game's state or overlay plumbing.

in-package#:mcluv
defconstant+metabar-width+460
defconstant+metabar-top-pad+8
defconstant+metabar-pad+18
defconstant+metabar-track-right+400
defunmetabar-alpha-ink
redgreenbluealpha
compose-in
make-rgb-colorredgreenblue
make-opacityalpha

Every background ink carries alpha into the direct compositor. Its solid and analytic shaders premultiply rgb before the ordinary OVER blend.

defparameter*metabar-shadow-ink*
metabar-alpha-ink0.00.00.00.34
defparameter*metabar-edge-ink*
metabar-alpha-ink0.420.460.400.82
defparameter*metabar-panel-ink*
metabar-alpha-ink0.0700.0730.0660.90
defparameter*metabar-row-ink*
metabar-alpha-ink0.160.160.150.68
defparameter*metabar-header-ink*
metabar-alpha-ink0.120.1250.1150.76
defparameter*metabar-track-ink*
metabar-alpha-ink0.300.300.280.82
defparameter*metabar-fill-ink*
metabar-alpha-ink0.580.780.540.96
defparameter*metabar-rebuild-ink*
metabar-alpha-ink0.850.680.400.98
defparameter*metabar-knob-ink*
make-rgb-color0.930.930.90
defparameter*metabar-text-ink*
make-rgb-color0.910.890.82
defparameter*metabar-muted-ink*
make-rgb-color0.600.600.55
defparameter*metabar-error-ink*
make-rgb-color0.940.480.40

--------------------------------------------------------------------- Application protocol.

defgenericmetabar-groups-for
owner
:documentation

Return owner's ordered group identities. Group identities remain owned by the application; symbols are sufficient when they are the vocabulary.

defgenericmetabar-group-label
ownergroup
:documentation

Return group's short label in owner's metabar.

defmethodmetabar-group-label
owner
groupsymbol
declare
ignoreowner
substitute#\Space#\-
string-downcasegroup
defmethodmetabar-group-label
owner
groupstring
declare
ignoreowner
group
defgenericmetabar-controls-for
ownergroup
:documentation

Return owner's ordered controls in group.

defgenericmetabar-actions-for
owner
:documentation

Return owner's ordered metabar actions.

defmethodmetabar-actions-for
owner
declare
ignoreowner
nil
defgenericmetabar-control-kind
controlowner
:documentation

Return :SCALAR or :switch for control in owner.

defgenericmetabar-control-label
controlowner
:documentation

Return control's short label in owner.

defgenericmetabar-control-value
controlowner
:documentation

Return control's cheap authored value. This runs during owner refresh, never inside repaint.

defgenericmetabar-control-value-label
controlownervalue
:documentation

Format the already observed value for control.

defmethodmetabar-control-value-label
controlownervalue
declare
ignorecontrolowner
princ-to-stringvalue
defgenericmetabar-control-fraction
controlownervalue
:documentation

Return scalar value's clamped position from 0 to 1.

defgenericmetabar-control-change-kind
controlowner
:documentation

Return NIL for an immediate value, or a short semantic marker such as :REBUILD when realizing control involves deferred derived work.

defmethodmetabar-control-change-kind
controlowner
declare
ignorecontrolowner
nil
defgenericmetabar-control-update-policy
controlowner
:documentation

Return :CONTINUOUS or :COMMIT-ON-RELEASE. The latter previews a pointer drag but applies only its last value after release, which keeps expensive derived work out of motion-event bursts.

defmethodmetabar-control-update-policy
controlowner
declare
ignorecontrolowner
:continuous
defgenericperform-metabar-control-step
controlownerdirectionmultiplier
:documentation

At owner's frame boundary, move control by signed direction and multiplier.

defgenericperform-metabar-control-set-fraction
controlownerfraction
:documentation

At owner's frame boundary, set scalar control from clamped fraction.

defgenericperform-metabar-control-toggle
controlowner
:documentation

At owner's frame boundary, toggle switch control.

defgenericmetabar-action-label
actionowner
:documentation

Return action's short button label in owner.

defgenericperform-metabar-action
actionowner
:documentation

Invoke action at owner's frame boundary.

--------------------------------------------------------------------- Cached vocabulary, rows, and operations.

defstructmetabar-vocabularygroupscontrol-groupsactions
defstructmetabar-rowkindcontrol-kindsubjectlabelheightcountvaluevalue-labelfractionchange-kindupdate-policy
defstructmetabar-operationkindsubjectargument
defuncapture-metabar-vocabulary
owner

Capture owner's small semantic vocabulary outside repaint.

let
groups
copy-list
make-metabar-vocabulary:groupsgroups:control-groups
mapcar
lambda
group
consgroup
copy-list
groups
:actions
copy-list
defunmetabar-vocabulary-controls
vocabularygroup
cdr
assocgroup
metabar-vocabulary-control-groupsvocabulary
:test#'eq
defunmetabar-natural-height-for
ownervocabulary

Return the fixed logical height which fits vocabulary's largest group.

++metabar-top-pad+
*+metabar-header-height+
length
metabar-vocabulary-groupsvocabulary
reduce#'max
metabar-vocabulary-groupsvocabulary
:key
lambda
group
reduce#'+:key
lambda
control
:initial-value0
:initial-value0
*+metabar-action-height+
length
metabar-vocabulary-actionsvocabulary
+metabar-status-height++metabar-bottom-pad+
defvar*metabar-construction-height*600"Logical height used while MAKE-EMBEDDED-METABAR realizes its layout."
define-application-framemetabar
owner:initarg:owner:readermetabar-owner
vocabulary:initarg:vocabulary:accessormetabar-vocabulary
logical-height:initarg:logical-height:readermetabar-logical-height
rows:initformnil:accessormetabar-rows
selected:initform0:accessormetabar-selected
open-group:initformnil:accessormetabar-open-group
dragging:initformnil:accessormetabar-dragging
preview-fractions:initformnil:accessormetabar-preview-fractions
pending-operations:initformnil:accessormetabar-pending-operations
diagnostic:initformnil:accessormetabar-diagnostic
dirty-p:initformt:accessormetabar-dirty-p
:menu-barnil
:panes
bar
:layouts
defaultbar
defunmake-metabar-control-row
framecontrol
let*
owner
metabar-ownerframe
kind
value
make-metabar-row:kind:control:control-kindkind:subjectcontrol:label:height:valuevalue:value-label:fraction
metabar-control-fractioncontrolownervalue
:change-kind:update-policy
defunrebuild-metabar-rows

Rebuild frame's retained row vocabulary after a structural change.

let*
owner
metabar-ownerframe
open-group
metabar-open-groupframe
setf
metabar-rowsframe
append
loopforgroupin
metabar-vocabulary-groupsvocabulary
collect
make-metabar-row:kind:group:subjectgroup:label:height+metabar-header-height+:count
when
eqgroupopen-group
append
mapcar
lambda
control
mapcar
lambda
make-metabar-row:kind:action:subjectaction:label:height+metabar-action-height+
metabar-vocabulary-actionsvocabulary
when
plusp
length
metabar-rowsframe
setf
metabar-selectedframe
mod
metabar-selectedframe
length
metabar-rowsframe
setf
metabar-dirty-pframe
t
frame
defmethodinitialize-instance:after
unless
metabar-open-groupframe
setf
metabar-open-groupframe
first
metabar-vocabulary-groups
defunrefresh-metabar-vocabulary

Re-read frame's groups, controls, and actions outside repaint.

unless
member
metabar-open-groupframe
metabar-vocabulary-groups
:test#'eq
setf
metabar-open-groupframe
first
metabar-vocabulary-groups
defunmetabar-selected-row
nth
metabar-selectedframe
metabar-rowsframe
defunmetabar-row-top
frameindex
++metabar-top-pad+
loopforrowin
metabar-rowsframe
repeatindexsum
metabar-row-heightrow
defunmetabar-row-at

Return the visible row index at local logical Y, or NIL.

let
loopforrowin
metabar-rowsframe
forindexfrom0forbottom=
+top
metabar-row-heightrow
when
and
<=topy
<ybottom
returnindexdo
setftopbottom
defunmetabar-control-row
framecontrol
findcontrol
metabar-rowsframe
:key
lambda
row
and
eq:control
metabar-row-kindrow
metabar-row-subjectrow
:test#'eq
defuninvalidate-metabar

Record a semantic revision. Repainting waits for the owner's refresh boundary.

setf
metabar-dirty-pframe
t
frame
defunrefresh-metabar-state

Observe visible control values outside repaint and invalidate on change.

let
owner
metabar-ownerframe
changed-pnil
dolist
row
metabar-rowsframe
when
eq:control
metabar-row-kindrow
let*
control
metabar-row-subjectrow
value
change-kind
unless
equalpvalue
metabar-row-valuerow
setf
metabar-row-valuerow
value
metabar-row-value-labelrow
metabar-row-fractionrow
metabar-control-fractioncontrolownervalue
changed-pt
unless
eqlchange-kind
metabar-row-change-kindrow
setf
metabar-row-change-kindrow
change-kind
changed-pt
frame
defunmetabar-preview-fraction
framecontrol
cdr
assoccontrol
metabar-preview-fractionsframe
:test#'eq
defun
fractionframecontrol
let
entry
assoccontrol
metabar-preview-fractionsframe
:test#'eq
ifentry
setf
cdrentry
fraction
push
conscontrolfraction
metabar-preview-fractionsframe
fraction
defunclear-metabar-preview-fraction
framecontrol
let
previews
metabar-preview-fractionsframe
when
assoccontrolpreviews:test#'eq
setf
metabar-preview-fractionsframe
deletecontrolpreviews:key#'car:test#'eq

The committed application value may quantize back to its old value. Removing the retained preview is nevertheless a visible revision.

frame
defunqueued-metabar-operation
operationskindsubject
find-if
lambda
operation
and
eqkind
metabar-operation-kindoperation
eqsubject
metabar-operation-subjectoperation
operations
defunqueue-metabar-operation
framekindsubject&optionalargument

Queue one small semantic operation without invoking application code.

let*
operations
metabar-pending-operationsframe
existing
queued-metabar-operationoperationskindsubject
cond
andexisting
eqkind:set-fraction
setf
metabar-operation-argumentexisting
argument
andexisting
eqkind:step
incf
metabar-operation-argumentexisting
argument

Opposite nudges in one input burst cancel before an expensive owner realization (for example shader rebuilding) can observe a no-op.

when
zerop
metabar-operation-argumentexisting
setf
metabar-pending-operationsframe
deleteexistingoperations:test#'eq
t
setf
metabar-pending-operationsframe
appendoperations
list
make-metabar-operation:kindkind:subjectsubject:argumentargument
frame
defunperform-metabar-operation
frameoperation
let
owner
metabar-ownerframe
subject
metabar-operation-subjectoperation
argument
metabar-operation-argumentoperation
ecase
metabar-operation-kindoperation
:step
perform-metabar-control-stepsubjectowner
if
minuspargument
-11
absargument
:set-fraction
:action
defunmetabar-operation-held-p
frameoperation
and
eq:set-fraction
metabar-operation-kindoperation
eq
metabar-operation-subjectoperation
metabar-draggingframe
let
row
metabar-control-rowframe
metabar-operation-subjectoperation
androw
eq:commit-on-release
metabar-row-update-policyrow
defundrain-metabar-operations

Apply queued edits at the owner boundary, retaining commit-style drags.

let
pending
metabar-pending-operationsframe
retainednil
diagnosticnil
attempted-pnil
setf
metabar-pending-operationsframe
nil
dolist
operationpending
if
pushoperationretained
progn
setfattempted-pt
handler-case
unwind-protect

A failed commit must not leave its optimistic preview displayed as though the owner accepted it.

ignore-errors
clear-metabar-preview-fractionframe
metabar-operation-subjectoperation
error
condition

A development instrument should leave the application alive and put the failure where the human can see it.

setfdiagnosticcondition
setf
metabar-pending-operationsframe
nreverseretained
when
andattempted-p
not
eqdiagnostic
metabar-diagnosticframe
setf
metabar-diagnosticframe
diagnostic
frame

--------------------------------------------------------------------- Painting: cached semantic rows only, direct GPU only.

define-conditionmetabar-requires-direct-gpu
error
object:initarg:object:readermetabar-non-gpu-object
:report
lambda
conditionstream
formatstream"The metabar requires retained direct GPU media, not ~S."
metabar-non-gpu-objectcondition
define-conditionmetabar-direct-presentation-violation
error
reason:initarg:reason:readermetabar-presentation-violation-reason
:report
lambda
conditionstream
formatstream"The metabar violated its direct presentation contract: ~A."
metabar-presentation-violation-reasoncondition
defunensure-metabar-gpu-medium
medium
unless
typepmedium'luv-gpu-medium
error'metabar-requires-direct-gpu:objectmedium
medium
defundraw-metabar-group-row
mediumrowtopselected-popen-p
let
bottom
+top
metabar-row-heightrow
whenselected-p
draw-text*medium
ifopen-p"▾""▸"
+metabar-pad+
/
+topbottom
2
:align-y:center:text-size15:ink
draw-text*medium
metabar-row-labelrow
/
+topbottom
2
:align-y:center:text-size15:text-face:bold:ink
draw-text*medium
formatnil"~D"
metabar-row-countrow
/
+topbottom
2
:align-x:right:align-y:center:text-size13:ink*metabar-muted-ink*
defundraw-metabar-control-title
mediumrowtopselected-p
draw-text*medium
metabar-row-labelrow
+metabar-pad+
+top24
:align-y:center:text-size17:ink*metabar-text-ink*
when
metabar-row-change-kindrow
draw-circle*medium
++metabar-pad+10
text-sizemedium
metabar-row-labelrow
:text-style
make-text-stylenilnil17
+top24
4:ink*metabar-rebuild-ink*
draw-text*medium
metabar-row-value-labelrow
+top24
:align-x:right:align-y:center:text-size17:text-face:bold:ink
defundraw-metabar-scalar-row
framemediumrowtopselected-p
let*
track-y
+top52
control
metabar-row-subjectrow
fraction
ifpreviewpreview
metabar-row-fractionrow
draw-metabar-control-titlemediumrowtopselected-p
draw-text*medium"−"track-y:align-x:center:align-y:center:text-size24:ink*metabar-muted-ink*
draw-text*medium"+"track-y:align-x:center:align-y:center:text-size24:ink*metabar-muted-ink*
draw-circle*mediumknob-xtrack-y10:ink*metabar-panel-ink*
draw-circle*mediumknob-xtrack-y8:ink*metabar-knob-ink*
defundraw-metabar-switch-row
mediumrowtopselected-p
let*
y
+top
/
metabar-row-heightrow
2
left
-right48
on-p
not
null
metabar-row-valuerow
draw-text*medium
metabar-row-labelrow
+metabar-pad+y:align-y:center:text-size17:ink*metabar-text-ink*
draw-circle*medium
ifon-p
-right12
+left12
y8:ink*metabar-knob-ink*
whenselected-p
draw-metabar-selection-markmediumtop
+top
metabar-row-heightrow
defundraw-metabar-control-row
framemediumrowtopselected-p
let
bottom
+top
metabar-row-heightrow
when
andselected-p
eq:scalar
metabar-row-control-kindrow
ecase
metabar-row-control-kindrow
:scalar
draw-metabar-scalar-rowframemediumrowtopselected-p
:switch
draw-metabar-switch-rowmediumrowtopselected-p
defundraw-metabar-action-row
mediumrowtopselected-p
let
bottom
+top
metabar-row-heightrow
draw-text*medium
metabar-row-labelrow
/
+topbottom
2
:align-x:center:align-y:center:text-size16:ink
defmethodhandle-repaint
region
declare
ignoreregion
let
frame
pane-framepane
with-bounding-rectangle*
lefttoprightbottom
pane
with-sheet-medium
mediumpane
draw-analytic-rounded-rectangle*medium
+left5
+top7
rightbottom:radius16:ink*metabar-shadow-ink*
draw-analytic-rounded-rectangle*mediumlefttoprightbottom:radius15:ink*metabar-edge-ink*
draw-analytic-rounded-rectangle*medium
+left2
+top2
-right2
-bottom2
:radius13:ink*metabar-panel-ink*
let
loopforrowin
metabar-rowsframe
forindexfrom0forselected-p=
=index
metabar-selectedframe
do
ecase
metabar-row-kindrow
:group
draw-metabar-group-rowmediumrowyselected-p
eq
metabar-row-subjectrow
metabar-open-groupframe
:control
draw-metabar-control-rowframemediumrowyselected-p
:action
draw-metabar-action-rowmediumrowyselected-p
incfy
metabar-row-heightrow
let
status-y
-
metabar-logical-heightframe
+metabar-bottom-pad+5
if
metabar-diagnosticframe
draw-text*medium"change failed · inspect the metabar"+metabar-pad+status-y:align-y:bottom:text-size12:ink*metabar-error-ink*
draw-text*medium"↑↓ choose · ←→ change · space applies"+metabar-pad+status-y:align-y:bottom:text-size12:ink*metabar-muted-ink*
defunmetabar-mirror
frame&key
errorpt

Return frame's embedded direct-GPU mirror.

let*
sheet
frame-top-level-sheetframe
mirror
andsheet
sheet-direct-mirrorsheet
cond
typepmirror'luv-gpu-mirror
mirror
errorp
error'metabar-requires-direct-gpu:objectmirror
tnil
defunvalidate-metabar-direct-presentation

Assert frame has no raster backing, fallback, or prepared image command.

let*
sheet
mirror-sheetmirror
when
mirror-texturemirror
error'metabar-direct-presentation-violation:reason"the embedded mirror acquired a backing texture"
dolist
painted-sheet
let
when
error'metabar-direct-presentation-violation:reason
formatnil"~S used decomposed primitive fallbacks"painted-sheet
when
find-if
lambda
command
error'metabar-direct-presentation-violation:reason"a rasterized image command reached the prepared stream"
frame
defunrepaint-metabar

Publish frame's cached semantic stream without drawable acquisition or wait.

alexandria:when-let
mirror
unless
and
mirror-embedded-pmirror
null
mirror-texturemirror
error'metabar-requires-direct-gpu:objectmirror
setf
metabar-dirty-pframe
nil
frame
defunprepare-metabar

Ensure frame's next direct composition sees its latest semantic revision.

frame

--------------------------------------------------------------------- Logical placement and input.

defunmetabar-panel-scale
source-logical-extentviewport-logical-extent
destructuring-bind
source-widthsource-height
source-logical-extent
declare
ignoresource-width
destructuring-bind
viewport-widthviewport-height
viewport-logical-extent
declare
ignoreviewport-width
min1.0
/source-height
defunmetabar-placement-state
source-logical-extentviewport-logical-extentslide

Return the left-drawer affine state in destination logical pixels.

At scale one, one metabar coordinate is one logical viewport pixel. A 2x drawable therefore evaluates every analytic edge and glyph at 2x native samples rather than enlarging a pane raster.

destructuring-bind
source-widthsource-height
source-logical-extent
destructuring-bind
viewport-widthviewport-height
viewport-logical-extent
let*
scale
metabar-panel-scalesource-logical-extentviewport-logical-extent
half-width
/
*source-widthscale
viewport-width
half-height
/
*source-heightscale
viewport-height
slide
max0.0
min1.0slide
eased
-1.0
expt
-1.0slide
3
center-x
+-1.0
*half-width
-
*2.0eased
1.0
make-array12:element-type'single-float:initial-contents
mapcar
lambda
value
coercevalue'single-float
listcenter-x0.00.01.0half-width0.00.00.00.0half-height0.00.0
defunmetabar-screen-state
frameviewport-logical-extentslide
metabar-placement-state
list+metabar-width+
metabar-logical-heightframe
viewport-logical-extentslide
defunmetabar-local-coordinate
framepointer-xpointer-yviewport-logical-extentslide

Map a destination-logical pointer into frame, or return NIL.

let*
source-extent
list+metabar-width+
metabar-logical-heightframe
scale
metabar-panel-scalesource-extentviewport-logical-extent
display-height
*
metabar-logical-heightframe
scale
slide
max0.0
min1.0slide
eased
-1.0
expt
-1.0slide
3
left
*display-width
-eased1.0
top
*0.5
-
secondviewport-logical-extent
display-height
when
and
<=leftpointer-x
+leftdisplay-width
<=toppointer-y
+topdisplay-height
values
/
-pointer-xleft
scale
/
-pointer-ytop
scale
defunselect-metabar-row
frameindex
let
count
length
metabar-rowsframe
when
pluspcount
let
selection
modindexcount
unless
=selection
metabar-selectedframe
setf
metabar-selectedframe
selection
frame
defunopen-metabar-group
framegroup
when
andgroup
not
eqgroup
metabar-open-groupframe
setf
metabar-open-groupframe
group
let
index
positiongroup
metabar-rowsframe
:key
lambda
row
and
eq:group
metabar-row-kindrow
metabar-row-subjectrow
:test#'eq
frame
defunnudge-metabar-selection
framedirectionmultiplier
alexandria:when-let
case
metabar-row-kindrow
:control
queue-metabar-operationframe:step
metabar-row-subjectrow
*directionmultiplier
:group
open-metabar-groupframe
metabar-row-subjectrow
frame
defunpress-metabar-selection
alexandria:when-let
ecase
metabar-row-kindrow
:group
open-metabar-groupframe
metabar-row-subjectrow
:control
when
eq:switch
metabar-row-control-kindrow
queue-metabar-operationframe:toggle
metabar-row-subjectrow
:action
queue-metabar-operationframe:action
metabar-row-subjectrow
frame
defunset-metabar-from-track
framerowfraction
let*
control
metabar-row-subjectrow
fraction
max0.0
min1.0fraction
queue-metabar-operationframe:set-fractioncontrolfraction
frame
defunhandle-metabar-key-event
frameevent

Handle a portable key press without invoking OWNER; return :CONTINUE or :DISMISS.

when
luv:canvas-key-event-repeat-pevent
return-fromhandle-metabar-key-event:continue
let
key
luv:canvas-key-event-key-nameevent
multiplier
if
member:shift
luv:canvas-key-event-modifiersevent
101
casekey
:escape:dismiss
:return:keypad-enter
:up:k
:continue
:down:j
:continue
:left:h
:continue
:right:l
:continue
t:continue
defunhandle-metabar-pointer-event
frameeventlocal-xlocal-y

Handle one pointer event already projected into frame logical coordinates.

let
row-index
typecaseevent
luv:canvas-pointer-button-release-event
setf
metabar-draggingframe
nil
:continue
luv:canvas-pointer-wheel-event
whenrow-index
let
row
nthrow-index
metabar-rowsframe
when
eq:control
metabar-row-kindrow
let
delta
luv:canvas-pointer-event-scroll-yevent
unless
zeropdelta
:continue
luv:canvas-pointer-button-press-event
when
androw-index
eq:left
luv:canvas-pointer-event-buttonevent
let
row
nthrow-index
metabar-rowsframe
case
metabar-row-kindrow
:group
open-metabar-groupframe
metabar-row-subjectrow
:action
queue-metabar-operationframe:action
metabar-row-subjectrow
:control
:continue
t:continue

--------------------------------------------------------------------- Embedded frame ownership.

defunmake-embedded-metabar
ownercanvascontextdevice&key
title"metabar"

Create owner's direct-GPU metabar on its existing canvas and device.

let*
port
find-port:server-path'
:luv-gpu
manager
or
first
climi::frame-managersport
make-instance'luv-frame-manager:portport
frame
let
make-application-frame'metabar:frame-managermanager:enablet:ownerowner:vocabularyvocabulary:logical-heightheight
setf
frame-pretty-nameframe
title
handler-case
let
unless
and
mirror-embedded-pmirror
null
mirror-texturemirror
error'metabar-requires-direct-gpu:objectmirror
frame
error
condition
unless
eq:disowned
frame-stateframe
destroy-frameframe
errorcondition
defundestroy-metabar

Release frame's mirror, retained buffers, and McCLIM ownership.

check-typeframemetabar
unless
eq:disowned
frame-stateframe
destroy-frameframe
nil