198 lines
5 KiB
Scheme
198 lines
5 KiB
Scheme
(module (bd ui) ()
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken module)
|
|
raylib
|
|
(imugi core)
|
|
(imugi math)
|
|
(imugi drawing)
|
|
(imugi resource)
|
|
(imugi input)
|
|
(srfi 1)
|
|
(srfi 4)
|
|
(srfi 99))
|
|
|
|
(define base-font (font "../res/fonts/Felipa-Regular.ttf"))
|
|
|
|
(define-record-type <label>
|
|
(int:make-label position centered? layer font font-size color text)
|
|
label?
|
|
(position label-pos set-label-pos!)
|
|
(centered? label-centered? set-label-centered!)
|
|
(layer label-layer set-label-layer!)
|
|
(font-size label-size set-label-size!)
|
|
(font label-font set-label-font!)
|
|
(color label-color set-label-color!)
|
|
(text label-text set-label-text!))
|
|
|
|
(export title)
|
|
(define (title position text
|
|
#!key
|
|
(centered (cons #f #f))
|
|
(layer 0)
|
|
(font base-font)
|
|
(size 128)
|
|
(color (make-color 0 0 0 1)))
|
|
(int:make-label position centered layer font size color text))
|
|
|
|
(export subtitle)
|
|
(define (subtitle position text
|
|
#!key
|
|
(centered (cons #f #f))
|
|
(layer 0)
|
|
(font base-font)
|
|
(size 36)
|
|
(color (make-color 0 0 0 1)))
|
|
(int:make-label position centered layer font size color text))
|
|
|
|
(export footer)
|
|
(define (footer position text
|
|
#!key
|
|
(centered (cons #f #f))
|
|
(layer 0)
|
|
(font base-font)
|
|
(size 24)
|
|
(color (make-color 0 0 0 1)))
|
|
(int:make-label position centered layer font size color text))
|
|
|
|
(export draw-labels)
|
|
(define draw-labels
|
|
(make-system
|
|
'draw-labels
|
|
10
|
|
'entity
|
|
'(<label>)
|
|
(lambda (_ label)
|
|
(push-render-object
|
|
'screen
|
|
(label-layer label)
|
|
(lambda ()
|
|
(let* (;; measure text length in pixels in case
|
|
;; we need it for horizontal centering
|
|
(text-length (f32vector->list
|
|
(measure-text-ex
|
|
(resource-contents (label-font label))
|
|
(label-text label)
|
|
(label-size label)
|
|
1)))
|
|
;; center the x/y of the position
|
|
;; based on label-centered?
|
|
(draw-pos (vec
|
|
(if (car (label-centered? label))
|
|
(- (/ (car (*window-size*))
|
|
2)
|
|
(/ (car text-length)
|
|
2))
|
|
(v-x (label-pos label)))
|
|
(if (cdr (label-centered? label))
|
|
(- (/ (cdr (*window-size*))
|
|
2)
|
|
(cadr text-length))
|
|
(v-y (label-pos label))))))
|
|
(draw-font-text-2d
|
|
draw-pos
|
|
(label-text label)
|
|
(label-size label)
|
|
(label-color label)
|
|
(label-font label))))))))
|
|
|
|
(define-record-type <button>
|
|
(int:make-button position size layer label state click-fn colors)
|
|
button?
|
|
(position button-pos set-button-pos!)
|
|
(size button-size set-button-size!)
|
|
(layer button-layer set-button-layer!)
|
|
(label button-label set-button-label!)
|
|
(state button-state set-button-state!)
|
|
(click-fn button-click-fn set-button-click-fn!)
|
|
(colors button-colors set-button-colors!))
|
|
|
|
(export button)
|
|
(define (button position label click-fn
|
|
#!key
|
|
(layer 0)
|
|
(size (vec 100 60))
|
|
(colors (list (make-color 0.48 0.48 0.48 1)
|
|
(make-color 0.63 0.63 0.63 1)
|
|
(make-color 0.39 0.39 0.39 1))))
|
|
(int:make-button position size layer label 'ready click-fn colors))
|
|
|
|
(define (check-button-state button)
|
|
(let ((x-range (cons (v-x (button-pos button))
|
|
(+ (v-x (button-pos button))
|
|
(v-x (button-size button)))))
|
|
(y-range (cons (v-y (button-pos button))
|
|
(+ (v-y (button-pos button))
|
|
(v-y (button-size button)))))
|
|
(mouse-pos (cons (get-mouse-x) (get-mouse-y))))
|
|
(if (and (< (car x-range) (car mouse-pos) (cdr x-range))
|
|
(< (car y-range) (cdr mouse-pos) (cdr y-range)))
|
|
(if (peek-event 'input 'click)
|
|
(set-button-state! button 'clicked)
|
|
(set-button-state! button 'hovered))
|
|
(set-button-state! button 'ready))))
|
|
|
|
(define (draw-button button)
|
|
(push-render-object
|
|
'screen
|
|
(button-layer button)
|
|
(lambda ()
|
|
(draw-rectangle-2d
|
|
(button-pos button)
|
|
(number->integer (v-x (button-size button)))
|
|
(number->integer (v-y (button-size button)))
|
|
(list-ref (button-colors button)
|
|
(case (button-state button)
|
|
((ready) 0)
|
|
((hovered) 1)
|
|
((clicked) 2)))
|
|
#t
|
|
1)))
|
|
(let* ((txt (button-label button))
|
|
(text-length (f32vector->list
|
|
(measure-text-ex
|
|
(resource-contents (label-font txt))
|
|
(label-text txt)
|
|
(label-size txt)
|
|
1)))
|
|
(center-offset (vec (- (/ (v-x (button-size button))
|
|
2)
|
|
(/ (car text-length)
|
|
2))
|
|
(- (/ (v-y (button-size button))
|
|
2)
|
|
(/ (cadr text-length)
|
|
2)))))
|
|
(push-render-object
|
|
'screen
|
|
(+ 1 (button-layer button))
|
|
(lambda ()
|
|
(draw-font-text-2d
|
|
(v+ (button-pos button)
|
|
center-offset)
|
|
(label-text txt)
|
|
(label-size txt)
|
|
(label-color txt)
|
|
(label-font txt))))))
|
|
|
|
(define (do-button-callback button)
|
|
(when (eqv? 'clicked (button-state button))
|
|
((button-click-fn button))))
|
|
|
|
(export handle-buttons)
|
|
(define handle-buttons
|
|
(make-system
|
|
'handle-buttons
|
|
10
|
|
'batch
|
|
'(<button>)
|
|
(lambda (buttons)
|
|
(for-each
|
|
(lambda (b)
|
|
(let ((button (find button? b)))
|
|
(check-button-state button)
|
|
(draw-button button)
|
|
(do-button-callback button)))
|
|
buttons)
|
|
(pop-event 'input 'click))))
|
|
)
|