luv

Workshop wiki

application-status-bar.lisp

mcclim/application-status-bar.lisp

system luv/mcclim · 65 definitions · on GitHub

A small application-wide semantic status line.

The render thread calls refresh-status-bar once per frame. That hot path increments one counter and reads the monotonic clock; semantic sampling is capped, throttled, and contains no transport or subprocess work. McCLIM retains analytic media and Slug text which the application's final GPU pass evaluates directly at the drawable's native resolution.

in-package#:mcluv
defconstant+status-bar-height+28
defparameter*status-bar-sample-seconds*1/2"Minimum time between complete semantic status samples."
defunstatus-bar-alpha-ink
redgreenbluealpha
compose-in
make-rgb-colorredgreenblue
make-opacityalpha
defparameter*status-bar-panel-ink*
status-bar-alpha-ink0.0100.0120.0140.72
defparameter*status-bar-edge-ink*
status-bar-alpha-ink0.680.720.700.19
defparameter*status-bar-text-ink*
make-rgb-color0.860.880.86
defparameter+status-bar-base-channels+'
:application:pid:fps:heap:lobby:worktree
"The application-neutral status vocabulary, in presentation order."
defgenericstatus-bar-channels-for
owner
:documentation

Return owner's ordered status channel symbols.

The default method supplies the application channels. A game adds sparse fields with an ordinary method which appends to CALL-NEXT-METHOD; it never has to replace the status frame or its sampling and presentation policy.

defmethodstatus-bar-channels-for
ownert
declare
ignoreowner
defgenericstatus-bar-channel-label
channelowner
:documentation

Return channel's compact label in owner's status line.

defmethodstatus-bar-channel-label
channelsymbol
owner
declare
ignoreowner
string-downcase
symbol-namechannel
defgenericstatus-bar-channel-value
channelownerstatus-bar
:documentation

Return channel's cheap semantic value for owner and status-bar.

Methods run only on the throttled frame-boundary sample, never during paint. They must inspect already-owned state and must not perform I/O or wait.

defgenericstatus-bar-application-name
owner
:documentation

Return owner's short application identity.

defmethodstatus-bar-application-name
ownert
string-downcase
princ-to-string
type-ofowner
defgenericstatus-bar-lobby-client
owner
:documentation

Return owner's shared lobby client, or NIL.

defmethodstatus-bar-lobby-client
ownert
declare
ignoreowner
nil
defgenericstatus-bar-source-root
owner
:documentation

Return owner's source checkout directory, or NIL.

defmethodstatus-bar-source-root
ownert
declare
ignoreowner
ignore-errors
asdf:system-source-directory"luv"
defvar*status-bar-worktree-cache*
make-hash-table:test#'equal
defvar*status-bar-worktree-cache-lock*
sb-thread:make-mutex:name"status bar worktree cache"
defunstatus-bar-directory-name
directory
let
components
pathname-directory
uiop:ensure-directory-pathnamedirectory
princ-to-string
or
car
lastcomponents
"checkout"
defunstatus-bar-read-first-line
pathname
handler-case
with-open-file
streampathname:direction:input
read-linestreamnilnil
error
nil
defunstatus-bar-git-directory
let*
root
uiop:ensure-directory-pathnameroot
dot-git
merge-pathnames".git"root
cond
uiop:directory-exists-pdot-git
uiop:ensure-directory-pathnamedot-git
uiop:file-exists-pdot-git
let
when
andline
string-equal"gitdir: "line:end28
uiop:ensure-directory-pathname
merge-pathnames
subseqline8
root
tnil
defunstatus-bar-git-branch
alexandria:when-let*
head
status-bar-read-first-line
merge-pathnames"HEAD"git-directory
let
prefix"ref: refs/heads/"
if
and
>=
lengthhead
lengthprefix
string=prefixhead:end2
lengthprefix
subseqhead
lengthprefix
subseqhead0
defundiscover-status-bar-worktree

Read root's worktree identity without invoking Git or another process.

whenroot
let
root
uiop:ensure-directory-pathnameroot
make-status-bar-worktree:name:branch
defuncached-status-bar-worktree

Return root's immutable worktree description, discovering it only once.

whenroot
let
key
namestring
uiop:ensure-directory-pathnameroot
sb-thread:with-mutex
multiple-value-bind
valuepresent-p
defunstatus-bar-worktree-description
worktree
whenworktree
let
name
status-bar-worktree-nameworktree
branch
status-bar-worktree-branchworktree
ifbranch
formatnil"~A@~A"namebranch
name
defstructstatus-bar-fieldchannellabelvalue
defvar*status-bar-construction-width*1024"Logical width used while MAKE-EMBEDDED-STATUS-BAR realizes its pane."
define-application-framestatus-bar
owner:initarg:owner:readerstatus-bar-owner
logical-width:initarg:logical-width:accessorstatus-bar-logical-width
worktree:initarg:worktree:readerstatus-bar-worktree
visible-fields:initformnil:accessorstatus-bar-visible-fields
fps:initform0d0:accessorstatus-bar-fps
frames-since-sample:initform0:accessorstatus-bar-frames-since-sample
last-sample-ticks:initform
get-internal-real-time
:accessorstatus-bar-last-sample-ticks
revision:initform0:accessorstatus-bar-revision
painted-revision:initform-1:accessorstatus-bar-painted-revision
repaint-count:initform0:accessorstatus-bar-repaint-count
dirty-p:initformt:accessorstatus-bar-dirty-p
:menu-barnil
:layouts
defaultbar
defmethodstatus-bar-channel-label
channel
eql:application
owner
declare
ignorechannelowner
nil
defmethodstatus-bar-channel-value
channel
eql:application
owner
declare
ignorechannelbar
defmethodstatus-bar-channel-value
channel
eql:pid
owner
declare
ignorechannelownerbar
princ-to-string
sb-posix:getpid
defmethodstatus-bar-channel-value
channel
eql:fps
owner
declare
ignorechannelowner
if
plusp
status-bar-fpsbar
formatnil"~D"
round
status-bar-fpsbar
"--"
defunstatus-bar-byte-description
bytes
cond
>=bytes
expt10243
formatnil"~,1FG"
/bytes
coerce
expt10243
'double-float
>=bytes
expt10242
formatnil"~DM"
roundbytes
expt10242
>=bytes1024
formatnil"~DK"
roundbytes1024
t
formatnil"~DB"bytes
defmethodstatus-bar-channel-value
channel
eql:heap
owner
declare
ignorechannelownerbar
status-bar-byte-description
sb-kernel:dynamic-usage
defmethodstatus-bar-channel-value
channel
eql:lobby
owner
declare
ignorechannelbar
alexandria:if-let
multiple-value-bind
statuspeer-count
formatnil"~(~A~) ~D"statuspeer-count
"off"
defmethodstatus-bar-channel-value
channel
eql:worktree
owner
declare
ignorechannelowner
defuntruncate-status-bar-string
text
if
concatenate'string"..."

Status fields are retained across frames. Even a short value must be detached from a game-owned adjustable or otherwise mutable string so later mutation cannot bypass the bar's revision publication.

copy-seqtext
defunbounded-status-bar-text
value
truncate-status-bar-string
typecasevalue

truncate-status-bar-string reads only the retained prefix of a huge game-supplied string; it never copies the discarded suffix.

stringvalue
t
let
*print-circle*t
*print-length*8
*print-level*3
*print-pretty*nil
princ-to-stringvalue
defunsample-status-bar-fields
bar

Copy one bounded immutable semantic field list from bar's owner.

let
owner
status-bar-ownerbar
loopforchannelinrepeat+status-bar-maximum-channels+forlabel=
handler-case
error
"error"
forvalue=
handler-case
error
"!"
whenvaluecollect
make-status-bar-field:channelchannel:label:value
defunstatus-bar-field-string
field
let
label
status-bar-field-labelfield
value
status-bar-field-valuefield
iflabel
formatnil"~A ~A"labelvalue
value
defunmeasured-status-bar-text-width
mediumtext

Return text's shaped advance in the status bar's one authored style.

nth-value0
text-sizemediumtext:text-style
make-text-stylenilnil+status-bar-text-size+
defunfitted-status-bar-field-strings
barmedium

Return the longest leading field sequence which fits bar's current width.

Fields retain semantic order and one font size. A narrow destination drops only trailing fields; even the first field is omitted when it cannot fit, so the text command never relies on clipping as its layout policy. Fitting uses the same Slug-shaped font advance as drawing, and only runs during a sparse semantic repaint.

let
available-width
max0
-
status-bar-logical-widthbar
accepted""
loopforfieldin
status-bar-visible-fieldsbar
fortext=forcandidate=
if
zerop
lengthaccepted
text
concatenate'stringaccepted+status-bar-field-separator+text
while
<=available-width
collecttextdo
setfacceptedcandidate
defunstatus-bar-display-string
barmedium
with-output-to-string
stream
loopfortextinforfirst-p=tthennilunlessfirst-pdodo
write-stringtextstream
defmethodhandle-repaint
region
declare
ignoreregion
let*
bar
pane-framepane
width
status-bar-logical-widthbar
with-sheet-medium
mediumpane

Both layers are analytic direct-GPU media. The panel's alpha reaches the game's already-rendered color through premultiplied blending.

Every field intentionally shares this exact face and size.

define-conditionstatus-bar-requires-direct-gpu
error
object:initarg:object:readerstatus-bar-non-gpu-object
:report
lambda
conditionstream
formatstream"The status bar requires retained direct GPU media, not ~S."
status-bar-non-gpu-objectcondition
define-conditionstatus-bar-direct-presentation-violation
error
reason:initarg:reason:readerstatus-bar-presentation-violation-reason
:report
lambda
conditionstream
formatstream"The status bar violated its direct presentation contract: ~A."
status-bar-presentation-violation-reasoncondition
defunstatus-bar-mirror
bar&key
errorpt
let*
sheet
frame-top-level-sheetbar
mirror
andsheet
sheet-direct-mirrorsheet
cond
typepmirror'luv-gpu-mirror
mirror
errorp
tnil
defunvalidate-status-bar-direct-presentation
bar
let*
sheet
mirror-sheetmirror
when
mirror-texturemirror
error'status-bar-direct-presentation-violation:reason"the embedded mirror acquired a raster texture"
dolist
painted-sheet
let
when
error'status-bar-direct-presentation-violation:reason"a pane used decomposed primitive fallbacks"
when
find-if
lambda
command
error'status-bar-direct-presentation-violation:reason"a raster image command reached the prepared stream"
bar
defunrepaint-status-bar
bar

Publish bar's retained semantic stream without acquiring a drawable.

alexandria:when-let
mirror
status-bar-mirrorbar:errorpnil
unless
and
mirror-embedded-pmirror
null
mirror-texturemirror
setf
status-bar-dirty-pbar
nil
status-bar-painted-revisionbar
status-bar-revisionbar
incf
status-bar-repaint-countbar
bar
defunprepare-status-bar
bar

Publish bar only when the throttled semantic snapshot actually changed.

bar
defunstatus-bar-pane-for
bar
find-pane-namedbar'bar
defunresize-status-bar
barlogical-width

Resize bar to logical-width without changing glyph scale or pixel density.

let
logical-width
max1
roundlogical-width
unless
=logical-width
status-bar-logical-widthbar
setf
status-bar-logical-widthbar
logical-width
status-bar-dirty-pbar
t
change-space-requirements:widthlogical-width:min-widthlogical-width:max-widthlogical-width:height+status-bar-height+:min-height+status-bar-height+:max-height+status-bar-height+:resize-framet
bar
defunrefresh-status-bar
barlogical-width&key
now
get-internal-real-time

Count one presented frame and occasionally publish a bounded state sample.

resize-status-barbarlogical-width
incf
status-bar-frames-since-samplebar
let*
before
status-bar-last-sample-ticksbar
elapsed-ticks
-nowbefore
sample-ticks
**status-bar-sample-seconds*internal-time-units-per-second
when
or
null
status-bar-visible-fieldsbar
>=elapsed-tickssample-ticks

The realization sample has no meaningful time window yet. Keep its explicit "--" and publish the first real cadence half a second later.

when
and
status-bar-visible-fieldsbar
pluspelapsed-ticks
setf
status-bar-fpsbar
/
*
status-bar-frames-since-samplebar
coerceinternal-time-units-per-second'double-float
elapsed-ticks
setf
status-bar-frames-since-samplebar
0
status-bar-last-sample-ticksbar
now
let
unless
equalpfields
status-bar-visible-fieldsbar
setf
status-bar-visible-fieldsbar
fields
status-bar-dirty-pbar
t
incf
status-bar-revisionbar
bar
defunstatus-bar-screen-state
barviewport-logical-extent

Return bar's top-edge affine in destination logical coordinates.

destructuring-bind
viewport-widthviewport-height
viewport-logical-extent
let*
source-width
status-bar-logical-widthbar
half-width
/source-widthviewport-width
half-height
/+status-bar-height+viewport-height

Direct McCLIM's affine follows the authored sheet convention: clip-space -1 is the screen top and +1 is the screen bottom.

center-y
+-1.0half-height
make-array12:element-type'single-float:initial-contents
mapcar
lambda
value
coercevalue'single-float
list0.0center-y0.01.0half-width0.00.00.00.0half-height0.00.0
defunmake-embedded-status-bar
ownercanvascontextdevicelogical-width&key
title"status"

Create owner's textureless retained status line on its application canvas.

let*
logical-width
max1
roundlogical-width
port
find-port:server-path'
:luv-gpu
manager
or
first
climi::frame-managersport
make-instance'luv-frame-manager:portport
barnil
completed-pnil
unwind-protect
progn
setfbar
let
make-application-frame'status-bar:frame-managermanager:enablet:ownerowner:logical-widthlogical-width:worktreeworktree
setf
frame-pretty-namebar
title
let
unless
and
mirror-embedded-pmirror
null
mirror-texturemirror
refresh-status-barbarlogical-width
setfcompleted-pt
bar
unlesscompleted-p
whenbar
ignore-errors
defundestroy-status-bar
bar
when
andbar
not
eq:disowned
frame-statebar
destroy-framebar
nil