351 lines
12 KiB
Racket
351 lines
12 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/async-channel racket/class racket/format racket/function racket/list racket/match
|
|
racket/string
|
|
ansi lux raart)
|
|
|
|
(provide activity% run-application
|
|
(struct-out app-event) fire-event
|
|
component% header/footer% scroll-pane% label% table% text-pane%)
|
|
|
|
;; internal synthetic event queue
|
|
(struct app-event [from tag data] #:transparent)
|
|
(define current-app-events (make-parameter #f))
|
|
|
|
;; fires an app event to the synthetic event queue
|
|
;; from should be a component% (or perhaps activity%) that triggered the event
|
|
;; tag should be a symbol describing the event type
|
|
;; data is anything
|
|
(define (fire-event from tag data)
|
|
(async-channel-put (current-app-events) (app-event from tag data)))
|
|
|
|
;; we're making a whole new thing for writing raart/lux applications
|
|
;; because it's more flexible than the word system, and it will allow us to have a "stack" of
|
|
;; activity windows which is a more useful abstraction
|
|
;; also, user-interface code is a good place where OOP is actually useful, and it's nicer than the
|
|
;; stock lux gen:word system
|
|
(define activity%
|
|
(class object%
|
|
(init-field root)
|
|
(init-field [fps 0.0])
|
|
(super-new)
|
|
|
|
;; returns a raart drawing
|
|
(define/public (draw size)
|
|
(send root draw size))
|
|
|
|
;; returns 'continue 'quit or another activity to start
|
|
(define/public (on-event e)
|
|
'continue)
|
|
|
|
;; internal top-level on-event which tries to send the event to the component tree first
|
|
(define/public (internal-on-event e)
|
|
;; see if the root component consumes the event
|
|
;; otherwise do the activity on-event handler
|
|
(if (send root on-event e)
|
|
'continue
|
|
(send this on-event e)))
|
|
|
|
;; same as on-event but for fps ticks
|
|
(define/public (on-tick)
|
|
'continue)
|
|
|
|
;; called when this activity is returned to
|
|
(define/public (on-return from-data)
|
|
(void))
|
|
|
|
;; called when this activity is starting
|
|
(define/public (on-activated)
|
|
(void))
|
|
|
|
;; called when this activity is stopping. can return a value for on-return of the previous
|
|
;; activity or to be printed, if this is the last activity
|
|
(define/public (on-deactivated)
|
|
(void))))
|
|
|
|
;; steps the word wrapper based on the result of calling an activity event or tick handler
|
|
(define (application-step word e)
|
|
(define stack (application-activity-stack word))
|
|
(define result
|
|
(if e
|
|
(send (first stack) internal-on-event e)
|
|
(send (first stack) on-tick)))
|
|
(match* (result stack)
|
|
[('continue stack) (struct-copy application word [activity-stack stack])]
|
|
[('quit (list act)) #f]
|
|
[('quit (list act act-next act-rest ...))
|
|
(send act-next on-return (send act on-deactivated))
|
|
(struct-copy application word [activity-stack (cons act-next act-rest)])]
|
|
[(act-next (list act act-rest ...))
|
|
(send act-next on-activated)
|
|
(struct-copy application word [activity-stack (cons act-next (cons act act-rest))])]))
|
|
|
|
;; an application is a word that runs an activity stack, until the last activity on the stack exits
|
|
(struct application [activity-stack size name]
|
|
#:methods gen:word
|
|
[(define (word-fps word)
|
|
(get-field fps (first (application-activity-stack word))))
|
|
(define (word-label word ft)
|
|
(application-name word))
|
|
(define (word-evt word)
|
|
(current-app-events))
|
|
(define (word-event word e)
|
|
(match e
|
|
;; intercept the screen-size-report
|
|
[(screen-size-report h w) (struct-copy application word [size (cons w h)])]
|
|
[_ (application-step word e)]))
|
|
(define (word-tick word)
|
|
(application-step word #f))
|
|
(define (word-output word)
|
|
(send (first (application-activity-stack word)) draw (application-size word)))
|
|
(define (word-return word)
|
|
(send (first (application-activity-stack word)) on-deactivated))])
|
|
|
|
;; creates and runs an application starting with a given first activity
|
|
(define (run-application name init-activity)
|
|
(define error-stream (open-output-string))
|
|
(define exit-message
|
|
(with-handlers ([exn? identity])
|
|
(parameterize ([current-error-port error-stream] [current-app-events (make-async-channel)])
|
|
(call-with-chaos
|
|
(make-raart #:mouse? #t)
|
|
(λ ()
|
|
(send init-activity on-activated)
|
|
(fiat-lux (application (list init-activity) (cons 80 24) name)))))))
|
|
|
|
;; raart is a bit fucky with the non-alternate screen so just clear it lol
|
|
(void (write-string (clear-screen/home))
|
|
(write-string (get-output-string error-stream) (current-error-port))
|
|
(displayln exit-message)))
|
|
|
|
|
|
;; ok now that there's an activity stack concept, the next enhancement is a layout engine
|
|
|
|
;; base TUI component
|
|
(define component%
|
|
(class object%
|
|
(init-field [parent #f])
|
|
(super-new)
|
|
|
|
;; draw this component with a size given by (cons w h)
|
|
;; w and h can be numbers to indicate a restriction in that dimension, or 'any to indicate any
|
|
;; size
|
|
(define/public (draw size)
|
|
(error "component draw"))
|
|
|
|
;; process an event and forward to children if necessary
|
|
;; #t if the event was consumed, otherwise #f
|
|
(define/public (on-event e)
|
|
#f)))
|
|
|
|
;; a component that vertically stacks a header, body, and footer
|
|
;; expects real width
|
|
;; forwards events to the body component
|
|
(define header/footer%
|
|
(class component%
|
|
(init-field header)
|
|
(init-field body)
|
|
(init-field footer)
|
|
(init-field [header-height 1])
|
|
(init-field [footer-height 1])
|
|
(super-new)
|
|
|
|
(set-field! parent header this)
|
|
(set-field! parent body this)
|
|
(set-field! parent footer this)
|
|
|
|
(define/override (draw size)
|
|
(match-define (cons w h) size)
|
|
(define body-h
|
|
(match h
|
|
['any 'any]
|
|
[_ (- h header-height footer-height)]))
|
|
|
|
(vappend (send header draw (cons w header-height))
|
|
(send body draw (cons w body-h))
|
|
(send footer draw (cons w footer-height))))
|
|
|
|
(define/override (on-event e)
|
|
(send body on-event e))))
|
|
|
|
;; a vertical scroll pane
|
|
;; expects real width and height
|
|
(define scroll-pane%
|
|
(class component%
|
|
(init-field body)
|
|
(super-new)
|
|
|
|
(set-field! parent body this)
|
|
|
|
(define scroll-y 0)
|
|
(define inner-size (cons 0 0))
|
|
(define screen-size (cons 80 24))
|
|
|
|
(define/public (focus-to y)
|
|
(when (> y (+ scroll-y (cdr screen-size)))
|
|
(set! scroll-y (max 0 (- y (cdr screen-size)))))
|
|
(when (< y scroll-y)
|
|
(set! scroll-y y))
|
|
(void))
|
|
|
|
(define/override (draw size)
|
|
(define body-rendered (send body draw (cons (car size) 'any)))
|
|
(set! screen-size size)
|
|
(set! inner-size (cons (raart-w body-rendered) (raart-h body-rendered)))
|
|
(when (> scroll-y (- (cdr inner-size) (cdr size)))
|
|
(set! scroll-y (max 0 (- (cdr inner-size) (cdr size)))))
|
|
(crop 0 (car size) scroll-y (cdr size) body-rendered))
|
|
|
|
(define/override (on-event e)
|
|
(or
|
|
(send body on-event e)
|
|
(match e
|
|
[(or "<up>" "k")
|
|
(set! scroll-y (max 0 (sub1 scroll-y)))
|
|
#t]
|
|
[(or "<down>" "j")
|
|
(set! scroll-y (min (cdr inner-size) (add1 scroll-y)))
|
|
#t]
|
|
[_ #f])))))
|
|
|
|
;; a basic text label
|
|
(define label%
|
|
(class component%
|
|
(init-field label-text)
|
|
(super-new)
|
|
|
|
(define/override (draw size)
|
|
(match-define (cons w h) size)
|
|
(define rendered (text label-text))
|
|
(define new-w (if (eq? w 'any) (raart-w rendered) w))
|
|
(define new-h (if (eq? h 'any) (raart-h rendered) h))
|
|
(matte new-w new-h rendered))))
|
|
|
|
;; a wrapped text pane
|
|
;; some day we'll support formatting lol
|
|
(define text-pane%
|
|
(class component%
|
|
(init content)
|
|
(super-new)
|
|
|
|
(define processed-content
|
|
(regexp-split #px"\r?\n" (regexp-replace* #px"\t" content " ")))
|
|
|
|
;; expects concrete w
|
|
(define/override (draw size)
|
|
(match-define (cons w h) size)
|
|
(define paras (map (λ (c) (para w c)) processed-content))
|
|
(define max-width
|
|
(for/fold ([max-width 0]) ([p (in-list paras)])
|
|
(max max-width (raart-w p))))
|
|
(define rendered-content
|
|
(vappend* (map (λ (p) (matte-at max-width (raart-h p) 0 0 p)) paras)))
|
|
(match h
|
|
['any rendered-content]
|
|
[_ (crop 0 w 0 h rendered-content)]))))
|
|
|
|
(define table%
|
|
(class component%
|
|
(init-field headers)
|
|
(init-field cells)
|
|
(init-field [flex-col 0])
|
|
(inherit-field parent)
|
|
(super-new)
|
|
|
|
(define selected-row 0)
|
|
|
|
(define/override (draw size)
|
|
(match-define (cons w h) size)
|
|
(define rows (length cells))
|
|
(define cols (length (first cells)))
|
|
(define min-width
|
|
(+ 1 cols
|
|
(for/sum ([i (in-range cols)] #:unless (= i flex-col))
|
|
(for/fold ([max-width 0]) ([row (in-list cells)])
|
|
(max max-width (string-length (list-ref row i)))))))
|
|
(define flex-col-w
|
|
(match w
|
|
['any (for/fold ([max-width 0]) ([row (in-list cells)])
|
|
(max max-width (string-length (list-ref row flex-col))))]
|
|
[_ (max 10 (- w min-width))]))
|
|
|
|
(define rendered-cells
|
|
(for/list ([row (in-list cells)] [ri (in-naturals)])
|
|
(for/list ([cell (in-list row)] [col (in-naturals)])
|
|
(define (cell-style x) (if (= ri selected-row) (with-drawing 'bold 'green #f x) x))
|
|
(cond
|
|
[(= col flex-col)
|
|
(define trimmed-str
|
|
(if (> (string-length cell) flex-col-w)
|
|
(string-append (substring cell 0 (- flex-col-w 3)) "...")
|
|
cell))
|
|
(matte-at flex-col-w 1 0 0 (cell-style (text trimmed-str)))]
|
|
[else (cell-style (text cell))]))))
|
|
|
|
(define rendered-header
|
|
(for/list ([t (in-list headers)])
|
|
(style 'bold (text t))))
|
|
|
|
(table (cons rendered-header rendered-cells)))
|
|
|
|
(define/override (on-event e)
|
|
(match e
|
|
[(or "<up>" "k")
|
|
(set! selected-row (max 0 (sub1 selected-row)))
|
|
(when (is-a? parent scroll-pane%)
|
|
(send parent focus-to (+ 0 (* 2 selected-row))))
|
|
#t]
|
|
[(or "<down>" "j")
|
|
(set! selected-row (min (sub1 (length cells)) (add1 selected-row)))
|
|
(when (is-a? parent scroll-pane%)
|
|
(send parent focus-to (+ 5 (* 2 selected-row))))
|
|
#t]
|
|
["C-M" (fire-event this 'selection selected-row) #t]
|
|
[_ #f]))))
|
|
|
|
;; test
|
|
(module+ main
|
|
(define stacky%
|
|
(class activity%
|
|
(init-field number)
|
|
(super-new [fps 0.0])
|
|
|
|
(define selected-row #f)
|
|
|
|
(define root
|
|
(new header/footer%
|
|
[header (new label% [label-text "this is the header"])]
|
|
[body (new scroll-pane%
|
|
[body (new table%
|
|
[headers '("title" "author")]
|
|
[cells '(("meow" "meow")
|
|
("meow 2" "meow 2")
|
|
("meow 3" "meow 3")
|
|
("meow 4" "meow 4")
|
|
("meow 5" "meow 5")
|
|
("meow 6" "meow 6")
|
|
("meow 7" "meow 7")
|
|
("meow 8" "meow 8")
|
|
("meow 9" "meow 9")
|
|
("meow 10" "meow 10")
|
|
("meow 11" "meow 11")
|
|
("meow 12" "meow 12")
|
|
("meow 13" "meow 13"))])])]
|
|
[footer (new label% [label-text "this is the footer"])]))
|
|
|
|
(define/override (draw size)
|
|
(send root draw size))
|
|
|
|
(define/override (on-event e)
|
|
(match e
|
|
["q" 'quit]
|
|
["n" (new stacky% [number (add1 number)])]
|
|
[(app-event _ 'selection row) (set! selected-row row) 'quit]
|
|
[_ (send root on-event e)
|
|
'continue]))
|
|
|
|
(define/override (on-deactivated)
|
|
(format "bye, meow ~a (selected row ~a)" number selected-row))))
|
|
|
|
(run-application "demo" (new stacky% [number 0])))
|