Adding values

README

@@ -1 +1,7 @@
 lux - a simple library for creating real-time graphical apps
+
+TODO
+xxx chaos/gui/mouse (take gui)
+xxx chaos/gui/key (take gui)
+xxx chaos/srpnt
+xxx chaos/gui/mode-lambda

chaos/gui/val.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+(require racket/class
+         racket/generic
+         racket/contract/base
+         pict
+         pict/convert
+         lux/chaos)
+
+(struct gui/val (scale? g)
+        #:methods gen:chaos
+        [(define/generic super-fps chaos-fps)
+         (define/generic super-yield chaos-yield)
+         (define/generic super-inputs chaos-inputs)
+         (define/generic super-output! chaos-output!)
+         (define/generic super-label! chaos-label!)
+         (define/generic super-swap! chaos-swap!)
+         (define (chaos-fps c)
+           (super-fps (gui/val-g c)))
+         (define (chaos-yield c e)
+           (super-yield (gui/val-g c) e))
+         (define (chaos-inputs c)
+           (super-inputs (gui/val-g c)))
+         (define (chaos-output! c o)
+           (define p (pict-convert o))
+           (super-output!
+            (gui/val-g c)
+            (λ (w h dc)
+              (send dc set-background "black")
+              (send dc clear)
+              (define sp
+                (if (gui/val-scale? c)
+                    (scale-to-fit p w h)
+                    p))
+              (define spw (pict-width sp))
+              (define left (/ (- w spw) 2))
+              (define sph (pict-height sp))
+              (define top (/ (- h sph) 2))
+              (send dc set-brush "white" 'solid)
+              (send dc draw-rectangle left top spw sph)
+              (draw-pict sp dc left top))))
+         (define (chaos-label! c l)
+           (super-label! (gui/val-g c) l))
+         (define (chaos-swap! c t)
+           (super-swap! (gui/val-g c) t))])
+
+(define (make-gui/value g #:scale? [scale? #t])
+  (gui/val scale? g))
+(provide
+ (contract-out
+  [make-gui/value
+   (->* (chaos?)
+        (#:scale? boolean?)
+        chaos?)]))

chaos/pair.rkt

@@ -0,0 +1,49 @@
+#lang racket/base
+(require racket/generic
+         racket/match
+         racket/sequence
+         racket/contract/base
+         lux/chaos)
+
+(struct pair (l r)
+        #:methods gen:chaos
+        [(define/generic super-fps chaos-fps)
+         (define/generic super-yield chaos-yield)
+         (define/generic super-inputs chaos-inputs)
+         (define/generic super-output! chaos-output!)
+         (define/generic super-label! chaos-label!)
+         (define/generic super-swap! chaos-swap!)
+         (define (chaos-fps c)
+           (match-define (pair l r) c)
+           (max (super-fps l)
+                (super-fps r)))
+         (define (chaos-yield c e)
+           (match-define (pair l r) c)
+           (super-yield l
+                        (handle-evt always-evt
+                                    (λ (_)
+                                      (super-yield r e)))))
+         (define (chaos-inputs c)
+           (match-define (pair l r) c)
+           (sequence-append (super-inputs l)
+                            (super-inputs r)))
+         (define (chaos-output! c o)
+           (match-define (pair l r) c)
+           (match-define (cons l.o r.o) o)
+           (super-output! l l.o)
+           (super-output! r r.o))
+         (define (chaos-label! c lab)
+           (match-define (pair l r) c)
+           (super-label! l lab)
+           (super-label! r lab))
+         (define (chaos-swap! c t)
+           (match-define (pair l r) c)
+           (super-swap! l (λ () (super-swap! r t))))])
+
+(define (make-pair l r)
+  (pair l r))
+(provide
+ (contract-out
+  [make-pair
+   (-> chaos? chaos?
+       chaos?)]))

examples/val-demo.rkt

@@ -0,0 +1,50 @@
+#lang racket/base
+(require racket/match
+         racket/fixnum
+         racket/gui/base
+         racket/class
+         (prefix-in pict: pict)
+         (prefix-in image: 2htdp/image)
+         lux
+         lux/chaos/gui
+         lux/chaos/gui/val)
+
+(define MODES
+  '(pict image))
+
+(struct demo
+  (mode)
+  #:methods gen:word
+  [(define (word-label s ft)
+     (lux-standard-label "Values" ft))
+   (define (word-tick w es)
+     (match-define (demo mode-n) w)
+     (define closed? #f)
+     (for ([e es])
+       (match e
+         ['close
+          (set! closed? #t)]
+         [(? (λ (x) (is-a? x key-event%)) ke)
+          (unless (eq? 'release (send ke get-key-code))
+            (set! mode-n (fxmodulo (fx+ 1 mode-n) (length MODES))))]
+         [_
+          (void)]))
+     (match closed?
+       [#t
+        (values #f w)]
+       [#f
+        (values
+         (demo mode-n)
+         (match (list-ref MODES mode-n)
+           ['pict
+            (pict:arrowhead 30 0)]
+           ['image
+            (image:add-line
+             (image:rectangle 100 100 "solid" "darkolivegreen")
+             25 25 75 75
+             (image:make-pen "goldenrod" 30 "solid" "round" "round"))]))]))])
+
+(module+ main
+  (call-with-chaos
+   (make-gui/value (make-gui 60.0))
+   (λ () (fiat-lux (demo 0)))))