Welcome to the CHICKEN Scheme pasting service

(use srfi-1 clojurian-syntax doodle matchable)

(define-record
  gui
  mouse-x
  mouse-y
  button-state
  hot
  active
  key)

(define (active? gui id)
  (equal? (gui-active gui) id))

(define (hot? gui id)
  (equal? (gui-hot gui) id))

(define (inside? mx my x y w h)
  (and (< x mx (+ x w))
       (< y my (+ y h))))

(define (do-button gui self x y width height label)
  (let ((m-x (gui-mouse-x gui))
        (m-y (gui-mouse-y gui))
        (button (gui-button-state gui))
        (gui (object-copy gui))
        (result #f))
    ; state transitions
    (cond ((and (active? gui self) (equal? button 'released) (inside? m-x m-y x y width height))
           (set! result #t)
           (gui-active-set! gui #f))
          ((and (hot? gui self) (equal? button 'pressed))
           (gui-active-set! gui self))
          ((inside? m-x m-y x y width height)
           (gui-hot-set! gui self))
          ((not (inside? m-x m-y x y width height))
           (when (active? gui self)
                 (gui-active-set! gui #f))
           (when (hot? gui self)
                 (gui-hot-set! gui #f))))
    ;; draw the button
    (filled-rectangle (+ x 5) (+ y 5) width height solid-black)
    (cond
     ((and (hot? gui self) (active? gui self))
      (filled-rectangle (+ x 5) (+ y 5) width height '(0 1 0 1))
      (text (+ x 20) (+ y 35) label))
     ((hot? gui self)
      (filled-rectangle x y width height '(0 1 0 1))
      (text (+ x 15) (+ y 30) label))
     (else
      (filled-rectangle x y width height '(0 0.7 0 1))
      (text (+ x 15) (+ y 30) label)))
    (list result gui)))

(define (feed-events state event)
  (let ((state (object-copy state)))
    (match event
           ((('mouse 'moved x y))
            (gui-mouse-x-set! state x)
            (gui-mouse-y-set! state y))
           ((('mouse button x y 1))
            (gui-mouse-x-set! state x)
            (gui-mouse-y-set! state y)
            (gui-button-state-set! state button))
           (else (void)))
    state))

(define *gui* '())

(world-inits
 (lambda ()
   (font-color solid-black)
   (font-size 18)
   (set! *gui* (make-gui 0 0 #f #f #f #f))))

(world-changes
 (lambda (events dt escape)
   (clear-screen)
   (as-> *gui* gui
         (feed-events gui events)
         (match-let (((ok? gui)
                      (do-button gui 'greet 10 10 150 50 "Hello World!")))
                    (when ok? (print "Hello World"))
                    gui)
         (match-let (((ok? gui)
                      (do-button gui 'quit 200 10 150 50 "Quit")))
                    (when ok? (escape 'gone))
                    gui)
         (set! *gui* gui))
   (show!)))

(new-doodle width: 360 height: 80 background: solid-white)
(run-event-loop)