94 lines
3.0 KiB
Racket
94 lines
3.0 KiB
Racket
#lang scheme/gui
|
|
|
|
(require htdp/error mzlib/pconvert)
|
|
|
|
(provide checked-cell%)
|
|
|
|
(define checked-cell<%>
|
|
(interface ()
|
|
set ;; Symbol Any -> Boolean
|
|
;; does the new state differ from the old?
|
|
;; effect: if so only, set state
|
|
|
|
get ;; -> Any (ok?)
|
|
))
|
|
|
|
(define checked-cell%
|
|
(class* object% (checked-cell<%>)
|
|
(init-field msg ;; String
|
|
value0 ;; X
|
|
ok?) ;; Any -> Boolean : X
|
|
|
|
(init [display #f]) ;; (U String #f) ; a string is the name of the state display window
|
|
|
|
(field
|
|
[value (coerce "initial value" value0)]
|
|
;; (U False pasteboard%)
|
|
[pb (if (boolean? display)
|
|
#f
|
|
(let* ([f (new frame% [label display][width 400][height 400])]
|
|
[p (new pasteboard%)]
|
|
[e (new editor-canvas% [parent f] [editor p]
|
|
[style '(hide-hscroll hide-vscroll)])])
|
|
(send f show #t)
|
|
p))])
|
|
|
|
(define/private (show-state)
|
|
(define xbox (box #f)) ;; x coordinate (throw away)
|
|
(define ybox (box 0)) ;; y coordinate for next snip
|
|
(define s
|
|
(pretty-format
|
|
(parameterize ([constructor-style-printing #t]
|
|
[booleans-as-true/false #t]
|
|
[abbreviate-cons-as-list
|
|
#t
|
|
;; is this beginner or beginner+quote
|
|
#;
|
|
(let ([o (open-output-string)])
|
|
(print '(1) o)
|
|
(regexp-match #rx"list" (get-output-string o)))])
|
|
(print-convert value))
|
|
40))
|
|
;; turn s into lines and display them in pb
|
|
(send pb erase)
|
|
(if (is-a? value snip%)
|
|
(send pb insert value 0 0)
|
|
(parameterize ([current-input-port (open-input-string s)])
|
|
(let read-all ()
|
|
(define nxt (read-line))
|
|
(unless (eof-object? nxt)
|
|
(let ([s (make-object string-snip% nxt)])
|
|
(send pb insert s 0 (unbox ybox))
|
|
(send pb get-snip-location s xbox ybox #t)
|
|
(read-all)))))))
|
|
|
|
;; Symbol Any -> ok?
|
|
(define/private (coerce tag nw)
|
|
(let ([b (ok? nw)])
|
|
(check-result "check-with predicate" boolean? "Boolean" b)
|
|
(check-result tag (lambda _ b) (format "~a (see check-with)" msg) nw)
|
|
nw))
|
|
|
|
;; Symbol Any -> Void
|
|
;; effect: set value to v if distinct, also display it if pb exists
|
|
(define/public (set tag v)
|
|
(define nw (coerce tag v))
|
|
;; this is the old Robby "optimization" for not triggering draw
|
|
;; when the world doesn't change
|
|
;if (equal? value nw)
|
|
; #t
|
|
(begin
|
|
(set! value nw)
|
|
(when pb (show-state))
|
|
#f))
|
|
|
|
;; -> ok?
|
|
(define/public (get) value)
|
|
|
|
(super-new)
|
|
|
|
(when pb (show-state))))
|
|
|
|
; (define c (new checked-cell% [msg "World"] [value0 1] [ok? positive?]))
|
|
; (send c set "tick" 10)
|