212 lines
8.9 KiB
Scheme
212 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:"))
|
|
|
|
;;; 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))
|
|
((dpad-left) (change-active-button -1))
|
|
((dpad-right) (change-active-button 1)))
|
|
(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))))))
|