ecmenu/menu-impl.scm

213 lines
8.9 KiB
Scheme

(import (scheme)
(chicken base)
(chicken format)
(chicken irregex)
(chicken keyword)
(chicken process)
(chicken process-context)
(srfi 18)
(srfi 69)
(toml)
(prefix sdl2 "sdl2:")
(prefix sdl2-image "img:")
(prefix sdl2-ttf "ttf:"))
(change-directory
(irregex-match-substring (irregex-search '(: bos (* any) #\/) (executable-pathname))))
;;; Configuration Handling
(define tomldata (table-from-file "menu.toml"))
(define launcher-entries
(let* ((launcher (toml-table tomldata "launcher"))
(entries (toml-array launcher "entry"))
(max-index (- (toml-count-entries entries) 1)))
(let accumulate ((index 0))
(if (< index max-index)
(cons (toml-table entries index)
(accumulate (+ index 1)))
(list (toml-table entries index))))))
;;; Data Loading
(define (load-image-texture renderer imgpath)
(sdl2:create-texture-from-surface renderer (img:load imgpath)))
(define (load-resources! renderer)
(map (lambda (entry)
(let ((id (string->keyword (toml-string entry "id")))
(image (toml-string entry "image")))
(hash-table-set! texstore id
(load-image-texture renderer image))))
launcher-entries)
(hash-table-set! texstore #:background
(load-image-texture renderer "media/images/background.png"))
(hash-table-set! texstore #:square
(load-image-texture renderer "media/images/square.png"))
(hash-table-set! fontstore #:fira-propo
(ttf:open-font "media/fonts/FiraCodeNerdFontPropo-Bold.ttf" 24)))
(define texstore (make-hash-table))
(define fontstore (make-hash-table))
(define debugtext "Initialized and ready.")
(define (render-debugtext renderer)
(let ((font (hash-table-ref fontstore #:fira-propo)))
(let-values (((tw th) (ttf:size-text font debugtext)))
(let ((rect (sdl2:make-rect 0 0 tw th)))
(sdl2:render-copy! renderer
(sdl2:create-texture-from-surface
renderer
(ttf:render-text-solid font debugtext (sdl2:make-colour)))
rect rect)))))
(define active-controllers '())
(define active-button-id 0)
(define button-bg-x 100)
(define button-bg-y 100)
(define button-mv-tickbuffer 0)
(define pixels-per-tick 1)
(define (button-coordinates index)
(values (+ 300 (* (modulo index 4) 350))
(+ 300 (* (floor (/ index 4)) 350))))
(define (move-button-bg!)
(let-values (((target-x target-y) (button-coordinates active-button-id)))
(let ((ticks (- (sdl2:get-ticks) button-mv-tickbuffer)))
(set! button-mv-tickbuffer (sdl2:get-ticks))
(cond ((< button-bg-x target-x)
(set! button-bg-x (min (+ button-bg-x (* pixels-per-tick ticks))
target-x)))
((> button-bg-x target-x)
(set! button-bg-x (max (- button-bg-x (* pixels-per-tick ticks))
target-x)))
(else #t))
(cond ((< button-bg-y target-y)
(set! button-bg-y (min (+ button-bg-y (* pixels-per-tick ticks))
target-y)))
((> button-bg-y target-y)
(set! button-bg-y (max (- button-bg-y (* pixels-per-tick ticks))
target-y)))
(else #t)))))
(define (render-square renderer x y rgb)
(let* ((square (hash-table-ref texstore #:square))
(srcrect (sdl2:make-rect 0 0 300 300))
(destrect (sdl2:make-rect x y 300 300)))
(sdl2:texture-colour-mod-set! square rgb)
(sdl2:render-copy! renderer square srcrect destrect)))
(define (render-launcher-button renderer index)
(let-values (((button-x button-y) (button-coordinates index)))
(let* ((entry (list-ref launcher-entries index))
(id (string->keyword (toml-string entry "id")))
(icon (hash-table-ref texstore id))
(srcrect (sdl2:make-rect 0 0 300 300))
(destrect (sdl2:make-rect (+ 20 button-x) (+ 20 button-y) 260 260)))
(sdl2:render-copy! renderer icon srcrect destrect))))
(define (render-launcher-buttons renderer)
(let loop ((index 0))
(render-launcher-button renderer index)
(when (< index (- (length launcher-entries) 1))
(loop (+ index 1)))))
(define (render-button-bgs renderer active-x active-y)
(let loop ((index 0))
(let-values (((button-x button-y) (button-coordinates index)))
(render-square renderer button-x button-y '(200 200 200)))
(when (< index (- (length launcher-entries) 1))
(loop (+ index 1))))
(render-square renderer active-x active-y '(100 100 100)))
(define (render-main-menu renderer ww wh)
(let ((texture (hash-table-ref texstore #:background))
(srcrec (sdl2:make-rect 0 0 1920 1080))
(dstrec (sdl2:make-rect 0 0 ww wh)))
(sdl2:render-clear! renderer)
(sdl2:render-copy! renderer texture srcrec dstrec)
(render-debugtext renderer)
(render-button-bgs renderer button-bg-x button-bg-y)
(render-launcher-buttons renderer)
(sdl2:render-present! renderer)))
(define (change-active-button delta)
(cond ((and (> delta 0) (< active-button-id 3))
(set! active-button-id (+ active-button-id delta)))
((and (< delta 0) (> active-button-id 0))
(set! active-button-id (+ active-button-id delta)))))
(define (trigger-action! window)
(set! active-controllers '())
(sdl2:quit-subsystem! '(events))
(process-wait (process-run (toml-string (list-ref launcher-entries active-button-id) "command")))
(sdl2:init-subsystem! '(events))
(sdl2:pump-events!)
(sdl2:flush-events!)
(sdl2:window-fullscreen-set! window 'fullscreen-desktop))
(define (handle-event ev window renderer ww wh exit-main-loop!)
(case (sdl2:event-type ev)
((window) (render-main-menu renderer ww wh))
((quit) (exit-main-loop! #t))
((controller-device-added) (begin (set! debugtext
(format "Event: Controller ~A added"
(sdl2:controller-device-event-which ev)))
(set! active-controllers
(cons (sdl2:game-controller-open!
(sdl2:controller-device-event-which ev))
active-controllers))))
((controller-device-removed) (set! debugtext "Event: Controller removed"))
((controller-axis-motion) (begin
(case (sdl2:controller-axis-event-axis ev)
((left-x) (cond ((< 0 (sdl2:controller-axis-event-value ev))
(change-active-button 1))
((> 0 (sdl2:controller-axis-event-value ev))
(change-active-button -1))
(else #t))))
(set! debugtext (format "Event: Axis ~A moved by ~A, active button is ~A"
(sdl2:controller-axis-event-axis ev)
(sdl2:controller-axis-event-value ev)
active-button-id))))
((controller-button-down) (begin
(case (sdl2:controller-button-event-button ev)
((a) (trigger-action! window)))
(set! debugtext (format "Controller button: ~A"
(sdl2:controller-button-event-button ev)))))
((key-down) (set! debugtext "Event: Key down"))
((key-up) (set! debugtext "Event: Key up"))
(else #f)))
(define (thread-delay! ms)
(thread-sleep! (* ms 0.001)))
(define (mainloop window renderer)
(let-values (((ww wh) (sdl2:window-size window)))
(let ((sdl2-event (sdl2:make-event)))
(call-with-current-continuation
(lambda (exit-main-loop!)
(let inner-loop ()
(render-main-menu renderer ww wh)
(move-button-bg!)
(let ((event (sdl2:wait-event-timeout! 50 sdl2-event thread-delay!)))
(when event (handle-event event window renderer ww wh exit-main-loop!)))
(inner-loop)))))))
(define (main #!optional args)
(sdl2:set-main-ready!)
(sdl2:init! '(everything))
(ttf:init!)
(sdl2:set-hint! 'render-scale-quality "best")
(let* ((window (sdl2:create-window! "Media Center" 'undefined 'undefined 1920 1080
'(shown allow-high-dpi fullscreen-desktop)))
(renderer (sdl2:create-renderer! window -1 '(accelerated target-texture))))
(load-resources! renderer)
(on-exit sdl2:quit!)
(thread-join!
(thread-start!
(lambda ()
(mainloop window renderer))))))