Buttons, labels, vbox and hbox work. click on a button and it changes shade briefly and the associated proc is called. So far it wasn't too hard and I think it is promising but text boxes, tree widgets, etc, scroll bars and more are needed. Some questions below.
[image: image.png]
Request for comments:
1. Please suggest a name for this UI, I'm calling it ckui for now.
2. If this project reached a decent level of implementation would you be
likely to use it?
3. I've modeled the interface after IUP and so far it is very similar.
Is this a pro or con?
4. Buttons and other moving widgets could be implemented with either iqm
models or sprite sheets. Which of those options would be more interesting
for you?
This is the guts of the calculator UI:
(gl:clear-color 0.8 0.8 0.8 1)
(show
(apply vbox
(label 'title "0123456789" 'w 120)
(map (lambda (lst)
(apply hbox
(map
(lambda (c)
(button
'title c
'w 30
'h 32
'action (lambda (obj)
(print "You pushed "c))))
lst)))
'(("1" "2" "3" "+")
("4" "5" "6" "-")
("7" "8" "9" "*")))
))
--
(module ckui
*
(import scheme
chicken.base
srfi-1
srfi-4
srfi-18
srfi-69
hypergiant
typed-records
)
(define valid-params
'((label 'title)))
(define font (cond-expand
(macosx "/Library/Fonts/Microsoft/Arial.ttf")
(windows (begin
(use posix)
(string-append (get-environment-variable "SYSTEMROOT")
"/Fonts/Arial.ttf")))
(else "/usr/share/fonts/truetype/msttcorefonts/arial.ttf")))
;; register widgets that can respond to mouse clicks or keyboard here
(define *active-widgets* (make-hash-table)) ;; obj => somename?
;; '(key1 val1 key2 val2 ...) => ((key1 . val1)(key2 . val2) ...)
(define (params->alist params)
(if (odd? (length params))
(begin
(print "FATAL: params->alist called with odd number of params, must be key-val pairs: "params)
(assert #f "FATAL: params->alist called with odd number of params"))
(let loop ((rem params)
(res '()))
(if (null? rem)
res
(let ((var (car rem))
(val (cadr rem)))
(loop (cddr rem) (cons (cons var val) res)))))))
(define (get-param params key #!optional (default #f))
(or (alist-ref key params) default))
(define (set-param! widget key val)
(gobj-params-set! widget
(cons (cons key val)
(filter (lambda (x)
(not (eq? (car x) key)))
(gobj-params widget)))))
(define (gobj-get-param gobj key)
(get-param (gobj-params gobj) key))
(define (label . keyvars)
(make-gobj objtype: 'label params: (params->alist keyvars)))
(define (button . keyvars)
(let* ((params (params->alist keyvars))
(name (get-param params 'name))
(gobj (make-gobj objtype: 'button params: params)))
(hash-table-set! *active-widgets* gobj name)
gobj))
(define (vbox . objs) ;; no params? have to use param-set! should be a
(make-gobj objtype: 'vbox objs: objs))
(define (hbox . objs) ;; no params? have to use param-set! should be a
(make-gobj objtype: 'hbox objs: objs))
;; generic graphic object
;;
(defstruct gobj
(objtype 'na)
(params '())
(objs '())
(currx0 0)
(curry0 0)
(currx1 0)
(curry1 0))
;; color='(r g b) 0-1
(define (rectangle-filled w h color)
(rectangle-mesh
w h
color: (lambda (i) color) ;; '(r g b) 0-1
centered?: #f))
(define (show-vbox widget params)
;; draw widgets from top to bottom
(let loop ((rem (gobj-objs widget))
(x (gobj-currx0 widget)) ;; start at upper left of the vbox location
(y (gobj-curry0 widget))
(maxx 0))
(if (not (null? rem))
(let* ((obj (car rem)))
(gobj-currx0-set! obj x) ;; set the origin for this obj
(gobj-curry0-set! obj y) ;;
(show obj)
(let* ((newmaxx (max maxx (gobj-currx1 obj))) ;; the new x1 maximum
(newmaxy (gobj-curry1 obj))) ;; on instantiation the curry1 was set
(gobj-currx1-set! widget newmaxx) ;; set it every time
(gobj-curry1-set! widget newmaxy)
(loop (cdr rem) x newmaxy newmaxx))))
widget))
(define (show-hbox widget params)
;; draw widgets from top to bottom
(let loop ((rem (gobj-objs widget))
(x (gobj-currx0 widget)) ;; start at upper left of the vbox location
(y (gobj-curry0 widget))
(maxy 0))
(if (not (null? rem))
(let* ((obj (car rem)))
(gobj-currx0-set! obj x)
(gobj-curry0-set! obj y)
(show obj)
(let* ((newmaxx (gobj-currx1 obj))
(newmaxy (min maxy (gobj-curry1 obj))))
(gobj-currx1-set! widget newmaxx)
(gobj-curry1-set! widget newmaxy)
(loop (cdr rem) newmaxx y newmaxy))))
widget))
(define (show-label widget params)
(let* ((title (get-param params 'title "n/a"))
(face (load-face font 20))
(title-mesh (string-mesh title face))
(title-w (string-width title face))
(title-h (face-height face))
(margin (get-param params 'margin 3))
(w (get-param params 'w (+ title-w 2 margin margin)))
(h (get-param params 'h (+ title-h 2 margin margin)))
(x (get-param params 'x (gobj-currx0 widget)))
(y (get-param params 'y (gobj-curry0 widget)))
(n1 (add-node ui color-pipeline-render-pipeline ;; the edge
position: (make-point 0 (- h) -0.2)
mesh: (rectangle-filled w h '(0.9 0.9 0.9))))
(n2 (add-node ui color-pipeline-render-pipeline ;; the background
position: (make-point 2 (- (- h 2)) -0.1)
mesh: (rectangle-filled (- w 4)(- h 4) ;; 4 for edge of 2 x 2
'(0.7 0.7 0.7))))
(t1 (add-node ui text-pipeline-render-pipeline
tex: (face-atlas (load-face font 20))
color: black
position: (make-point (+ margin 2)
(- (+ margin 2))
0)
mesh: title-mesh
usage: #:dynamic))
(location (f32vector x y 0)))
(set-param! widget 'n1 n1)
(set-param! widget 'n2 n2)
(set-param! widget 't1 t1)
(set-param! widget 'location location)
(move-node! n2 location)
(move-node! n1 location)
(move-node! t1 location)
(gobj-currx0-set! widget x)
(gobj-curry0-set! widget y)
(gobj-currx1-set! widget (+ x w))
(gobj-curry1-set! widget (- y h)) ;; y increases negative as we add widgets
))
(define (set-gobj-pushed gobj)
(case (gobj-objtype gobj)
((button)
(let* ((n2 (gobj-get-param gobj 'n2)))
;; (loc (gobj-get-param gobj 'location))
;; (newloc (f32vector (point-x loc)(point-y loc) -100)))
(move-node! n2 (f32vector -900 0 0))))))
(define (set-gobj-normal gobj)
(case (gobj-objtype gobj)
((button)
(let* ((n2 (gobj-get-param gobj 'n2)))
;; (loc (gobj-get-param gobj 'location)))
(move-node! n2 (f32vector 900 0 0))))))
(define (show widget)
(let* ((objtype (gobj-objtype widget))
(params (gobj-params widget)))
(case objtype
((label) (show-label widget params))
((button) (show-label widget params))
((vbox) (show-vbox widget params))
((hbox) (show-hbox widget params))
)))
;;======================================================================
;; mouse stuff
;;======================================================================
;; SDL has (point-in-rect? point rect)
(define (point-inside-gobj x y gobj)
(and (> x (gobj-currx0 gobj))
(< x (gobj-currx1 gobj))
(> y (gobj-curry1 gobj))
(< y (gobj-curry0 gobj))))
;; how to get the camera for ui scene? I hacked window.scm in hyperscene
;; and added *ui-camera* to exports
(define (ui-press)
(receive (near far)(get-cursor-world-position *ui-camera*)
(print "near: "near", far: "far)
(let* ((x (point-x near))
(y (point-y near)))
(let loop ((rem (hash-table-keys *active-widgets*)))
(if (not (null? rem))
(let* ((gobj (car rem))
(inrec (point-inside-gobj x y gobj)))
(if inrec
(let ((action (gobj-get-param gobj 'action)))
(set-gobj-pushed gobj)
(if (procedure? action)
(action gobj))
(thread-start! (make-thread (lambda ()
(thread-sleep! 0.25) ;; enough for at least one frame?
(set-gobj-normal gobj)))))
(loop (cdr rem)))))))))
(define mouse (make-bindings
`((left-click ,+mouse-button-left+
press: ,ui-press))))
)
Makefile
Description: Binary data
(include "ckui.scm")
(module example
*
(import scheme
chicken.base
hypergiant
ckui)
(define (init)
(let* ((bw 30)
(bh 35))
(push-mouse-bindings mouse)
(gl:clear-color 0.8 0.8 0.8 1)
(show
(apply vbox
(label 'title "0123456789" 'w 120)
(map (lambda (lst)
(apply hbox
(map
(lambda (c)
(button
'title c
'w 30
'h 32
'action (lambda (obj)
(print "You pushed "c))))
lst)))
'(("1" "2" "3" "+")
("4" "5" "6" "-")
("7" "8" "9" "*")))
))))
;; look at "with-window" for a self-cleanup way
(start 120 150 "Show" init: init resizable: #f)
)
