1029 lines
40 KiB
Racket
1029 lines
40 KiB
Racket
;;;============================================================================
|
|
;;; GCalc
|
|
;;; based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
|
|
;;; implemented by Eli Barzilay: Maze is Life! (eli@barzilay.org)
|
|
|
|
#lang mzscheme
|
|
|
|
(require mzlib/class mred mzlib/etc "../show-scribbling.ss" mzlib/unit)
|
|
(provide game@)
|
|
|
|
(define customs '())
|
|
(define (add-custom! name get set type desc)
|
|
(set! customs (append customs (list (make-custom name get set type desc)))))
|
|
(define-struct custom (name getter setter type description))
|
|
(define-syntax defcustom
|
|
(syntax-rules ()
|
|
[(_ var default type description)
|
|
(begin (define var default)
|
|
(add-custom! 'var (lambda () var) (lambda (v) (set! var v))
|
|
type description))]))
|
|
(define game@ (unit (import) (export)
|
|
|
|
;;;============================================================================
|
|
;;; Customizations etc
|
|
|
|
(defcustom EVAL-NOW #t 'bool "Evaluate immediately on application")
|
|
(defcustom EVAL-DEPTH 18 '(int 100) "Evaluation depth limit")
|
|
(defcustom DRAW-CUTOFF 8 '(int 50) "Cutoff evaluation when smaller")
|
|
(defcustom SPLIT-ARGS #f 'bool "Split arg by function body structure")
|
|
(defcustom COLOR-OPS #f 'bool "Use colors as functions")
|
|
(defcustom NOBMP-PRINT #f 'bool "Never use bitmaps to print")
|
|
|
|
(define DK-PEN (instantiate pen% ("BLACK" 1 'solid)))
|
|
(define LT-PEN (instantiate pen% ("WHITE" 1 'solid)))
|
|
|
|
(define COLORS
|
|
(map (lambda (c)
|
|
(list
|
|
(car c)
|
|
(cond [(null? (cdr c)) (instantiate pen% ("WHITE" 1 'transparent))]
|
|
[(eq? (car c) 'black) LT-PEN]
|
|
[else DK-PEN])
|
|
(if (null? (cdr c))
|
|
(instantiate brush% ("BLACK" 'transparent))
|
|
(instantiate brush% [(apply make-object color% (cdr c)) 'solid]))))
|
|
'((transparent)
|
|
(black 0 0 0)
|
|
(dk-gray 64 64 64)
|
|
(gray 128 128 128)
|
|
(lt-gray 192 192 192)
|
|
(white 255 255 255)
|
|
(dk-red 128 0 0)
|
|
(red 255 0 0)
|
|
(dk-green 0 128 0)
|
|
(green 0 255 0)
|
|
(dark-blue 0 0 128)
|
|
(blue 0 0 255)
|
|
(dk-yellow 128 128 0)
|
|
(yellow 255 255 0)
|
|
(dk-cyan 0 128 128)
|
|
(cyan 0 255 255)
|
|
(dk-magenta 128 0 128)
|
|
(magenta 255 0 255))))
|
|
|
|
(define COLOR-CELL-ROW 2)
|
|
(define COLOR-CELL-COL (/ (length COLORS) COLOR-CELL-ROW))
|
|
(define OPERS-CELL-ROW 3)
|
|
(define OPERS-CELL-COL 3)
|
|
(define STORE-CELL-ROW 5)
|
|
(define STORE-CELL-COL 8)
|
|
(define GLOBAL-HEIGHT (* 7 (lcm COLOR-CELL-COL OPERS-CELL-COL STORE-CELL-COL)))
|
|
|
|
(define COLOR-CELL-SIZE (/ GLOBAL-HEIGHT COLOR-CELL-COL))
|
|
(define OPERS-CELL-SIZE (/ GLOBAL-HEIGHT OPERS-CELL-COL))
|
|
(define STORE-CELL-SIZE (/ GLOBAL-HEIGHT STORE-CELL-COL))
|
|
|
|
(define SHOW-CELL-SIZE 600)
|
|
|
|
(define BG-PEN/BRUSH (list (instantiate pen% ["BLACK" 1 'solid])
|
|
(instantiate brush% ["GRAY" 'solid])))
|
|
(define XOR-PEN/BRUSH (list (instantiate pen% ["BLACK" 0 'xor])
|
|
(instantiate brush% ["BLACK" 'xor])))
|
|
|
|
(define DOUBLE-MILISECS 250)
|
|
|
|
(define CELL-BORDER 6)
|
|
|
|
(define CELL-FONT (instantiate font% (10 'decorative 'normal 'normal)))
|
|
(define SHOW-FONT (instantiate font% (32 'decorative 'normal 'normal)))
|
|
|
|
(define APPLY-SIZE 0.40)
|
|
(define ABSTR-GAP 0.1)
|
|
(define ABSTR-SIZE 0.3)
|
|
(define 3D-DX 0.4)
|
|
(define 3D-DY 0.5)
|
|
(define 3D-OFFSET (+ CELL-BORDER 2))
|
|
|
|
;;;============================================================================
|
|
;;; Utilities
|
|
|
|
(define 1st car)
|
|
(define 2nd cadr)
|
|
(define 3rd caddr)
|
|
(define 4th cadddr)
|
|
|
|
(define (eprintf . args)
|
|
(apply fprintf (current-error-port) args))
|
|
|
|
(define (read-from-string str)
|
|
(with-handlers ([void (lambda (x) #f)])
|
|
(let ([obj (read (open-input-string (string-append "(" str ")")))])
|
|
(and (list? obj) (= 1 (length obj)) (car obj)))))
|
|
|
|
(define (write-to-string obj)
|
|
(format "~s" obj))
|
|
|
|
(define (set-pen/brush dc p/b)
|
|
(send dc set-pen (1st p/b))
|
|
(send dc set-brush (2nd p/b)))
|
|
|
|
;;;============================================================================
|
|
;;; GCalc definition
|
|
|
|
(define var-num 0)
|
|
(define (get-next-vnum)
|
|
(set! var-num (add1 var-num))
|
|
var-num)
|
|
(define (make-var var)
|
|
(list 'var var
|
|
;;(get-next-vnum) - no need for this since we only use closed terms
|
|
))
|
|
(define (var-val var)
|
|
(2nd var))
|
|
(define (var-expr? expr)
|
|
(and (pair? expr) (eq? (1st expr) 'var)))
|
|
|
|
(define null-expr #f)
|
|
(define (null-expr? expr)
|
|
(eq? expr null-expr))
|
|
|
|
(define make-expr list)
|
|
(define expr-op 1st)
|
|
(define expr-1st 2nd)
|
|
(define expr-2nd 3rd)
|
|
|
|
(define (simple-expr? expr)
|
|
(or (not (pair? expr)) (eq? (car expr) 'var)))
|
|
(define (composite-expr? expr . type)
|
|
(and (pair? expr)
|
|
(if (null? type)
|
|
(not (eq? (car expr) 'var))
|
|
(eq? (expr-op expr) (car type)))))
|
|
|
|
(define (make-left-right expr1 expr2)
|
|
(make-expr '\| expr1 expr2))
|
|
(define (make-right-left expr1 expr2)
|
|
(make-left-right expr2 expr1))
|
|
(define (left-right-expr? expr)
|
|
(composite-expr? expr '\|))
|
|
|
|
(define (make-top-bottom expr1 expr2)
|
|
(make-expr '- expr1 expr2))
|
|
(define (make-bottom-top expr1 expr2)
|
|
(make-top-bottom expr2 expr1))
|
|
(define (top-bottom-expr? expr)
|
|
(composite-expr? expr '-))
|
|
|
|
(define (make-front-back expr1 expr2)
|
|
(make-expr '/ expr1 expr2))
|
|
(define (make-back-front expr1 expr2)
|
|
(make-front-back expr2 expr1))
|
|
(define (front-back-expr? expr)
|
|
(composite-expr? expr '/))
|
|
|
|
(define (make-application1 expr1 expr2)
|
|
(make-expr 'apply expr1 expr2))
|
|
(define (make-application2 expr1 expr2)
|
|
(make-expr 'apply expr2 expr1))
|
|
(define (application-expr? expr)
|
|
(composite-expr? expr 'apply))
|
|
|
|
(define (make-abstraction expr1 expr2)
|
|
(if (simple-expr? expr1)
|
|
(let ([var (make-var expr1)])
|
|
(make-expr 'lambda var (substitute var expr1 expr2)))
|
|
null-expr))
|
|
(define (abstraction-expr? expr)
|
|
(composite-expr? expr 'lambda))
|
|
|
|
(define (expr-size expr)
|
|
(if (composite-expr? expr)
|
|
(+ 1 (expr-size (expr-1st expr)) (expr-size (expr-2nd expr)))
|
|
1))
|
|
|
|
(define (recolor-expr color expr)
|
|
(define (get-rgb color)
|
|
(cond [(or (eq? color 'transparent) (null-expr? color)) color]
|
|
[(symbol? color)
|
|
(let ([c (send (3rd (assq color COLORS)) get-color)])
|
|
(list (send c red) (send c green) (send c blue)))]
|
|
[else (vector->list color)]))
|
|
(define (mix rgb1 rgb2)
|
|
(cond [(equal? rgb1 rgb2) (list->vector rgb1)]
|
|
[(or (null-expr? rgb1) (null-expr? rgb2)) null-expr]
|
|
[(or (eq? rgb1 'transparent) (eq? rgb2 'transparent)) 'transparent]
|
|
[else (list->vector (map (lambda (c1 c2)
|
|
(inexact->exact (round (/ (+ c1 c2) 2))))
|
|
rgb1 rgb2))]))
|
|
(let ([color (get-rgb color)])
|
|
(let loop ([expr expr])
|
|
(cond [(or (var-expr? expr) (null-expr? expr)) expr]
|
|
[(simple-expr? expr) (mix color (get-rgb expr))]
|
|
[else (make-expr (expr-op expr)
|
|
(loop (expr-1st expr))
|
|
(loop (expr-2nd expr)))]))))
|
|
|
|
(define (reduce-application expr . level)
|
|
(define (reduce expr level)
|
|
(if (and level (<= level 0))
|
|
expr
|
|
(let ([1st (let ([e (expr-1st expr)])
|
|
(if (application-expr? e)
|
|
(reduce-application e (and level (sub1 level)))
|
|
e))]
|
|
[2nd (expr-2nd expr)])
|
|
(cond
|
|
[(and COLOR-OPS (simple-expr? 1st) (not (var-expr? 1st)))
|
|
(recolor-expr 1st 2nd)]
|
|
[(or (simple-expr? 1st) (application-expr? 1st)) expr]
|
|
[(abstraction-expr? 1st)
|
|
(substitute 2nd (expr-1st 1st) (expr-2nd 1st))]
|
|
[else
|
|
(let ([2nd (split-expr 2nd (expr-op 1st))])
|
|
(make-expr (expr-op 1st)
|
|
(make-application1 (expr-1st 1st) (expr-1st 2nd))
|
|
(make-application1 (expr-2nd 1st) (expr-2nd 2nd))))]))))
|
|
(let* ([level (if (null? level) EVAL-DEPTH (car level))]
|
|
[new (reduce expr level)])
|
|
(if (and (application-expr? new) (not (equal? new expr))
|
|
(or (not level) (> level 0)))
|
|
(reduce-application new (and level (if (> level 0) (sub1 level) 0)))
|
|
new)))
|
|
|
|
#; ;; No need for this now
|
|
(define (eval-expr expr)
|
|
(define (eval-expr expr level)
|
|
(cond
|
|
[(zero? level) null-expr]
|
|
[(or (simple-expr? expr) (abstraction-expr? expr)) expr]
|
|
[(application-expr? expr)
|
|
(let ([1st (eval-expr (expr-1st expr) (sub1 level))]
|
|
[2nd (eval-expr (expr-2nd expr) (sub1 level))])
|
|
(cond
|
|
[(and COLOR-OPS (simple-expr? 1st) (not (var-expr? 1st)))
|
|
(recolor-expr 1st 2nd)]
|
|
[(or (simple-expr? 1st) (application-expr? 1st)) expr]
|
|
[(abstraction-expr? 1st)
|
|
(eval-expr (substitute 2nd (expr-1st 1st) (expr-2nd 1st))
|
|
(sub1 level))]
|
|
[else
|
|
(let ([2nd (split-expr (eval-expr 2nd (sub1 level)) (expr-op 1st))])
|
|
(make-expr
|
|
(expr-op 1st)
|
|
(eval-expr (make-application (expr-1st 1st) (expr-1st 2nd))
|
|
(sub1 level))
|
|
(eval-expr (make-application (expr-2nd 1st) (expr-2nd 2nd))
|
|
(sub1 level))))]))]
|
|
[else
|
|
(make-expr (expr-op expr)
|
|
(eval-expr (expr-1st expr) (sub1 level))
|
|
(eval-expr (expr-2nd expr) (sub1 level)))]))
|
|
(dynamic-wind
|
|
begin-busy-cursor
|
|
(lambda () (eval-expr expr (or EVAL-DEPTH -1)))
|
|
end-busy-cursor))
|
|
|
|
(define (split-expr expr op)
|
|
(cond
|
|
[(or (simple-expr? expr) (abstraction-expr? expr))
|
|
(make-expr op expr expr)]
|
|
[(eq? (expr-op expr) op) expr]
|
|
[else
|
|
(let* ([e1 (split-expr (expr-1st expr) op)]
|
|
[e2 (split-expr (expr-2nd expr) op)]
|
|
[e11 (expr-1st e1)]
|
|
[e12 (expr-2nd e1)]
|
|
[e21 (expr-1st e2)]
|
|
[e22 (expr-2nd e2)]
|
|
[e-op (expr-op expr)])
|
|
(make-expr op (make-expr e-op e11 e21) (make-expr e-op e12 e22)))]))
|
|
|
|
(define (substitute new old expr)
|
|
(cond
|
|
[(composite-expr? expr)
|
|
(if (and (abstraction-expr? expr) (equal? (expr-1st expr) old))
|
|
expr
|
|
(let-values ([(new1 new2) (if SPLIT-ARGS
|
|
(let ([x (split-expr new (expr-op expr))])
|
|
(values (expr-1st x) (expr-2nd x)))
|
|
(values new new))])
|
|
(make-expr (expr-op expr)
|
|
(substitute new1 old (expr-1st expr))
|
|
(substitute new2 old (expr-2nd expr)))))]
|
|
[(equal? expr old) new]
|
|
[else expr]))
|
|
|
|
(define (valid-expr? obj)
|
|
(cond [(null-expr? obj) #t]
|
|
[(list? obj) (case (length obj)
|
|
[(2) (and (eq? (1st obj) 'var)
|
|
(not (list? (2nd obj)))
|
|
(valid-expr? (2nd obj)))]
|
|
[(3 4) (case (car obj)
|
|
[(\| - / apply lambda)
|
|
(and (valid-expr? (expr-1st obj))
|
|
(valid-expr? (expr-2nd obj)))]
|
|
[else #f])])]
|
|
[(symbol? obj) (and (assq obj COLORS) #t)]
|
|
[(vector? obj) (and (= (vector-length obj) 3)
|
|
(let ([ok? (lambda (x)
|
|
(and (integer? x) (<= 0 x 255)))])
|
|
(and (ok? (vector-ref obj 0))
|
|
(ok? (vector-ref obj 1))
|
|
(ok? (vector-ref obj 2)))))]
|
|
[else #f]))
|
|
(define (valid-contents? obj)
|
|
(and (pair? obj)
|
|
(or (not (car obj)) (string? (car obj)))
|
|
(valid-expr? (cdr obj))))
|
|
(define (validate-contents obj)
|
|
(if (valid-contents? obj)
|
|
obj
|
|
(begin (eprintf "~s is not a valid contents.\n" obj)
|
|
(error 'validate-contents "~s is not a valid contents." obj))))
|
|
|
|
;;;============================================================================
|
|
;;; GCalc drawing
|
|
|
|
(define transparent?-cache (make-hash-table 'weak))
|
|
|
|
(define (expr-contains-transparent? expr)
|
|
(if (simple-expr? expr)
|
|
(or (null-expr? expr) (eq? expr 'transparent)
|
|
(and (var-expr? expr) (eq? (var-val expr) 'transparent)))
|
|
(let ([v (hash-table-get transparent?-cache expr 'unknown)])
|
|
(if (eq? v 'unknown)
|
|
(let ([v (cond [(abstraction-expr? expr)
|
|
(expr-contains-transparent? (expr-2nd expr))]
|
|
[(application-expr? expr)
|
|
#t]
|
|
[else (or (expr-contains-transparent? (expr-1st expr))
|
|
(expr-contains-transparent? (expr-2nd expr)))])])
|
|
(hash-table-put! transparent?-cache expr v)
|
|
v)
|
|
v))))
|
|
|
|
;; Draw an exprression - the smart way.
|
|
(define (draw-expr dc expr name . r)
|
|
(define size
|
|
(let-values ([(sx sy) (send dc get-size)]) (inexact->exact (min sx sy))))
|
|
(define eval? (if (null? r) #f (car r)))
|
|
(define (avg x y) (/ (+ x y) 2))
|
|
(define (rnd x) (inexact->exact (round x)))
|
|
(define dc-ofs 3D-OFFSET)
|
|
(define dc-size (- size dc-ofs dc-ofs))
|
|
(define draw-polygon ; efficient (could be more if it was global)
|
|
(let* ([p1 (instantiate point% ())] [p2 (instantiate point% ())]
|
|
[p3 (instantiate point% ())] [p4 (instantiate point% ())]
|
|
[points (list p1 p2 p3 p4)])
|
|
(lambda (x1 y1 x2 y2 x3 y3 x4 y4)
|
|
(send* p1 (set-x x1) (set-y y1)) (send* p2 (set-x x2) (set-y y2))
|
|
(send* p3 (set-x x3) (set-y y3)) (send* p4 (set-x x4) (set-y y4))
|
|
(send dc draw-polygon points))))
|
|
(define tmp-color (instantiate color% [])) ; reused for drawing colors
|
|
(define (draw expr level left? top? front? x1 y1 z1 x2 y2 z2 abstr)
|
|
(define eval? (or (not level) (> level 0)))
|
|
(define lev1 (and level (if (> level 0) (sub1 level) 0)))
|
|
(when (and eval? (application-expr? expr))
|
|
(set! expr (reduce-application expr level)))
|
|
(cond
|
|
[(null-expr? expr) expr]
|
|
[(composite-expr? expr)
|
|
(let ([1st (expr-1st expr)] [2nd (expr-2nd expr)])
|
|
(cond
|
|
[(left-right-expr? expr)
|
|
(let ([cut? (and DRAW-CUTOFF (< (* (- x2 x1) size) DRAW-CUTOFF))]
|
|
[x12 (avg x1 x2)]
|
|
[t? (expr-contains-transparent? 1st)])
|
|
(make-right-left
|
|
(if (and (not cut?) (or top? front? t?))
|
|
(draw 2nd lev1 t? top? front? x12 y1 z1 x2 y2 z2 .0) 2nd)
|
|
(if cut?
|
|
(draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
|
|
(draw 1st lev1 left? top? front? x1 y1 z1 x12 y2 z2 .0))))]
|
|
[(top-bottom-expr? expr)
|
|
(let ([cut? (and DRAW-CUTOFF (< (* (- y2 y1) size) DRAW-CUTOFF))]
|
|
[y12 (avg y1 y2)]
|
|
[t? (expr-contains-transparent? 1st)])
|
|
(make-bottom-top
|
|
(if (and (not cut?) (or left? front? t?))
|
|
(draw 2nd lev1 left? t? front? x1 y12 z1 x2 y2 z2 .0) 2nd)
|
|
(if cut?
|
|
(draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
|
|
(draw 1st lev1 left? top? front? x1 y1 z1 x2 y12 z2 .0))))]
|
|
[(front-back-expr? expr)
|
|
(let ([cut? (and DRAW-CUTOFF (< (* (- z2 z1) size) DRAW-CUTOFF))]
|
|
[z12 (avg z1 z2)]
|
|
[t? (expr-contains-transparent? 1st)])
|
|
(make-back-front
|
|
(if (and (not cut?) (or left? top? t?))
|
|
(draw 2nd lev1 left? top? t? x1 y1 z1 x2 y2 z12 .0) 2nd)
|
|
(if cut?
|
|
(draw 1st lev1 left? top? front? x1 y1 z1 x2 y2 z2 abstr)
|
|
(draw 1st lev1 left? top? front? x1 y1 z12 x2 y2 z2 .0))))]
|
|
[(abstraction-expr? expr)
|
|
(draw 2nd 0 left? top? front? x1 y1 z1 x2 y2 z2 (+ abstr ABSTR-GAP))
|
|
(set-pen/brush dc (cdr (assq (var-val 1st) COLORS)))
|
|
(let ([xx (+ (rnd (* (+ x1 (* (- x2 x1) abstr) (* 3D-DX z2))
|
|
(/ dc-size (+ 1 3D-DX))))
|
|
dc-ofs)]
|
|
[yy (+ (rnd (* (+ y1 (* 3D-DY z2)) (/ dc-size (+ 1 3D-DY))))
|
|
dc-ofs)]
|
|
[dx (rnd (* ABSTR-SIZE (- x2 x1) (/ dc-size (+ 1 3D-DX))))]
|
|
[dy (rnd (* ABSTR-SIZE (- y2 y1) (/ dc-size (+ 1 3D-DY))))])
|
|
(send dc draw-ellipse xx yy dx dy))
|
|
expr]
|
|
[(application-expr? expr)
|
|
(let* ([x12 (avg x1 x2)]
|
|
[y12 (avg y1 y2)]
|
|
[dx (* (- x2 x1) 1/2 APPLY-SIZE)]
|
|
[dy (* (- y2 y1) 1/2 APPLY-SIZE)]
|
|
[xx1 (- x12 dx)]
|
|
[yy1 (- y12 dy)]
|
|
[xx2 (+ x12 dx)]
|
|
[yy2 (+ y12 dy)]
|
|
[zz (* (- z2 z1) APPLY-SIZE)]
|
|
[z11 (+ z1 zz)]
|
|
[z22 (- z2 zz)])
|
|
(make-application1
|
|
(draw 1st lev1 left? top? front? xx1 yy1 z1 xx2 yy2 z11 .0)
|
|
(draw 2nd lev1 left? top? front? xx1 yy1 z22 xx2 yy2 z2 .0)))]
|
|
[else (error 'draw-expr "Unknown composite expr -- ~s." expr)]))]
|
|
[(simple-expr? expr)
|
|
(unless (eq? 'transparent (if (var-expr? expr) (var-val expr) expr))
|
|
(let* (;;
|
|
;; Calculate points:
|
|
;;
|
|
;; xx0xx1 xx2 xx3
|
|
;; | | | |
|
|
;; P---------P -- yy0
|
|
;; |\ \
|
|
;; | \ \
|
|
;; | P---------P-- yy1
|
|
;; | | |
|
|
;; P | |-- yy2
|
|
;; \ | |
|
|
;; \| |
|
|
;; P---------P-- yy3
|
|
;;
|
|
;; (xx1 - x1) = (x2 - xx2) = (3D-DX * (x2 - x1))
|
|
;; and the same for y values
|
|
;;
|
|
[dx (* 3D-DX (- z2 z1))]
|
|
[xx0 (+ x1 (* z1 3D-DX))]
|
|
[xx1 (+ xx0 dx)]
|
|
[xx2 (+ x2 (* z1 3D-DX))]
|
|
[xx3 (+ xx2 dx)]
|
|
[dy (* 3D-DY (- z2 z1))]
|
|
[yy0 (+ y1 (* z1 3D-DY))]
|
|
[yy1 (+ yy0 dy)]
|
|
[yy2 (+ y2 (* z1 3D-DY))]
|
|
[yy3 (+ yy2 dy)]
|
|
[xx00 (+ (rnd (* (/ xx0 (+ 1 3D-DX)) dc-size)) dc-ofs)]
|
|
[xx11 (+ (rnd (* (/ xx1 (+ 1 3D-DX)) dc-size)) dc-ofs)]
|
|
[xx22 (+ (rnd (* (/ xx2 (+ 1 3D-DX)) dc-size)) dc-ofs)]
|
|
[xx33 (+ (rnd (* (/ xx3 (+ 1 3D-DX)) dc-size)) dc-ofs)]
|
|
[yy00 (+ (rnd (* (/ yy0 (+ 1 3D-DY)) dc-size)) dc-ofs)]
|
|
[yy11 (+ (rnd (* (/ yy1 (+ 1 3D-DY)) dc-size)) dc-ofs)]
|
|
[yy22 (+ (rnd (* (/ yy2 (+ 1 3D-DY)) dc-size)) dc-ofs)]
|
|
[yy33 (+ (rnd (* (/ yy3 (+ 1 3D-DY)) dc-size)) dc-ofs)])
|
|
(set-pen/brush
|
|
dc
|
|
(cond
|
|
[(var-expr? expr) (cdr (assq (var-val expr) COLORS))]
|
|
[(symbol? expr) (cdr (assq expr COLORS))]
|
|
[else ; explicit color
|
|
(send tmp-color set
|
|
(vector-ref expr 0) (vector-ref expr 1) (vector-ref expr 2))
|
|
(list DK-PEN (send the-brush-list find-or-create-brush
|
|
tmp-color 'solid))]))
|
|
(draw-polygon xx11 yy11 xx00 yy00 xx22 yy00 xx33 yy11)
|
|
(draw-polygon xx11 yy11 xx00 yy00 xx00 yy22 xx11 yy33)
|
|
(draw-polygon xx11 yy11 xx33 yy11 xx33 yy33 xx11 yy33)))
|
|
expr]
|
|
[else (error 'draw-expr "Unknown expr -- ~s." expr)]))
|
|
(dynamic-wind
|
|
begin-busy-cursor
|
|
(lambda ()
|
|
(send dc clear)
|
|
(set-pen/brush dc BG-PEN/BRUSH)
|
|
(send dc draw-rectangle 1 1 size size)
|
|
(let ([expr (draw expr (if eval? EVAL-DEPTH 0)
|
|
#t #t #t .0 .0 .0 1.0 1.0 1.0 .0)])
|
|
(when name
|
|
(let-values ([(tw th d a) (send dc get-text-extent name)])
|
|
(let ([tw (min tw (- size 6))])
|
|
(set-pen/brush dc BG-PEN/BRUSH)
|
|
(send dc draw-rectangle (- size tw 3) 1 (+ 3 tw) (+ 2 th))
|
|
(send dc draw-text name (max 0 (- size tw 1)) 2))))
|
|
expr))
|
|
end-busy-cursor))
|
|
|
|
;;;============================================================================
|
|
;;; GUI
|
|
|
|
(define gcalc-frame
|
|
(instantiate
|
|
(class frame%
|
|
(define/augment (on-close) (maybe-save-and-exit))
|
|
(define/public (open-file file) (open file))
|
|
(super-instantiate ("GCalc") (style '(no-resize-border)))
|
|
(send this stretchable-width #f)
|
|
(send this stretchable-height #f))
|
|
()))
|
|
|
|
(define main-pane
|
|
(instantiate horizontal-pane% (gcalc-frame)))
|
|
|
|
(define help
|
|
(show-scribbling
|
|
'(lib "games/scribblings/games.scrbl")
|
|
"gcalc"))
|
|
|
|
(define file-name #f)
|
|
(define modified? #f)
|
|
(define (set-file-name! name)
|
|
(set! file-name name)
|
|
(send gcalc-frame set-label (string-append "GCalc: " name)))
|
|
(define (save)
|
|
(if file-name
|
|
(begin
|
|
(when (file-exists? file-name) (delete-file file-name))
|
|
(with-output-to-file file-name
|
|
(lambda ()
|
|
(dynamic-wind
|
|
begin-busy-cursor
|
|
(lambda ()
|
|
(define (out x) (write x) (newline))
|
|
(out "GCALC")
|
|
(for-each (lambda (c) (out ((custom-getter c)))) customs)
|
|
(out (send main-cell get-contents))
|
|
(out (get-storage-contents))
|
|
(set! modified? #f))
|
|
end-busy-cursor)
|
|
(message-box "Save" (format "~s saved." file-name)
|
|
gcalc-frame '(ok)))))
|
|
(save-as)))
|
|
(define (open-examples)
|
|
(open (path->string (build-path (this-expression-source-directory)
|
|
"gcalc-examples"))))
|
|
(define (open . file)
|
|
(maybe-save)
|
|
(let ([f (if (not (null? file))
|
|
(car file)
|
|
(cond [(get-file "Open" gcalc-frame) => path->string] [else #f]))])
|
|
(when f
|
|
(if (file-exists? f)
|
|
(with-input-from-file f
|
|
(lambda ()
|
|
(dynamic-wind
|
|
begin-busy-cursor
|
|
(lambda ()
|
|
(with-handlers
|
|
([exn:fail?
|
|
(lambda (x)
|
|
(message-box
|
|
"Open" (format "~s is not a GCalc file." f)
|
|
gcalc-frame '(ok)))])
|
|
(or (equal? "GCALC" (read)) (error "gcalc"))
|
|
(set-file-name! f)
|
|
(for-each (lambda (c) ((custom-setter c) (read))) customs)
|
|
(send main-cell set-contents! (validate-contents (read)))
|
|
(set-storage-contents! (map validate-contents (read)))
|
|
(set! modified? #f)))
|
|
end-busy-cursor)))
|
|
(message-box "Open" (format "~s does not exists." f)
|
|
gcalc-frame '(ok))))))
|
|
(define (save-as)
|
|
(let ([f (get-file "Save-as" gcalc-frame)])
|
|
(when f
|
|
(if (directory-exists? f)
|
|
(message-box
|
|
"Save-as" (format "\"~a\" is a directory." f) gcalc-frame '(ok))
|
|
(when (or (not (file-exists? f))
|
|
(eq? 'yes
|
|
(message-box
|
|
"Save-as" (format "\"~a\" exists, overwrite?" f)
|
|
gcalc-frame '(yes-no))))
|
|
(set-file-name! (path->string f))
|
|
(save))))))
|
|
(define (maybe-save)
|
|
(when (and modified?
|
|
(begin
|
|
(bell)
|
|
(eq? 'yes
|
|
(message-box
|
|
"GCalc" "Save modifications?" gcalc-frame '(yes-no)))))
|
|
(save)))
|
|
(define (maybe-save-and-exit)
|
|
(maybe-save)
|
|
(set! modified? #f) ; can appear again from drscheme
|
|
(send gcalc-frame show #f))
|
|
|
|
(define set-options
|
|
(let ([dlg (instantiate dialog% ("GCalc Expression" gcalc-frame))])
|
|
(define ok? #f)
|
|
(define inits (lambda () (set! ok? #f)))
|
|
(define finals (lambda () (set! modified? #t)))
|
|
(define (add-init/final initializer finalizer)
|
|
(let ([c inits]) (set! inits (lambda () (initializer) (c))))
|
|
(let ([c finals]) (set! finals (lambda () (finalizer) (c)))))
|
|
(define (new-row . a)
|
|
(let ([p (instantiate horizontal-pane% (dlg))])
|
|
(send p set-alignment (if (null? a) 'left (car a)) 'center)
|
|
p))
|
|
(define (make-check-box getter setter title)
|
|
(let ([cb (instantiate check-box% (title (new-row) void))])
|
|
(add-init/final (lambda () (send cb set-value (getter)))
|
|
(lambda () (setter (send cb get-value))))))
|
|
(define (make-check/slide getter setter title range)
|
|
(define row (new-row))
|
|
(define toggle
|
|
(instantiate check-box%
|
|
(title row
|
|
(let ([saved 0])
|
|
(lambda (this e)
|
|
(if (send this get-value)
|
|
(send slider set-value saved)
|
|
(begin (set! saved (send slider get-value))
|
|
(send slider set-value 0))))))))
|
|
(define slider
|
|
(instantiate slider%
|
|
["" 0 range row
|
|
(lambda (this e)
|
|
(send toggle set-value (not (zero? (send this get-value)))))]))
|
|
(add-init/final (lambda ()
|
|
(let ([val (getter)])
|
|
(send slider set-value (or val 0))
|
|
(send toggle set-value (and val #t))))
|
|
(lambda ()
|
|
(setter (and (send toggle get-value)
|
|
(send slider get-value))))))
|
|
(define (make-ok-cancel)
|
|
(let ([row (new-row 'center)])
|
|
(instantiate button%
|
|
["&OK" row (lambda (this e) (set! ok? #t) (send dlg show #f))]
|
|
[style '(border)])
|
|
(instantiate button%
|
|
["&Cancel" row (lambda (this e) (send dlg show #f))])))
|
|
;; Dialog components
|
|
(for-each (lambda (c)
|
|
(let ([type (custom-type c)]
|
|
[getter (custom-getter c)]
|
|
[setter (custom-setter c)]
|
|
[desc (custom-description c)])
|
|
(cond [(eq? type 'bool) (make-check-box getter setter desc)]
|
|
[(and (pair? type) (eq? (1st type) 'int))
|
|
(make-check/slide getter setter desc (2nd type))])))
|
|
customs)
|
|
(make-ok-cancel)
|
|
;; Main
|
|
(lambda () (inits) (send dlg show #t) (when ok? (finals)))))
|
|
|
|
(define cell-menu-items `((#\x "C&ut" cut:)
|
|
(#\c "&Copy" copy:)
|
|
(#\v "Pas&te" paste:)
|
|
(#\r "Clea&r" clear:)
|
|
(#\e "&Eval" eval:)
|
|
(#\n "Re&name" rename:)
|
|
(#\space "Sho&w" show:)
|
|
(#\p "&Print" print:)))
|
|
(define global-menu-items `((#\h "&Help" ,help)
|
|
(#\o "&Open" ,open)
|
|
(#\m "Open-Exa&mples" ,open-examples)
|
|
(#\s "&Save" ,save)
|
|
(#\a "Save-&as" ,save-as)
|
|
(#\return "Pre&ferences" ,set-options)
|
|
(#\q "&Quit" ,maybe-save-and-exit)))
|
|
|
|
(define popup-cell-menu
|
|
(let ([menu (instantiate popup-menu% ("GCalc"))]
|
|
[this #f]
|
|
[cell-items '()])
|
|
(define (make-item mi)
|
|
(cons
|
|
(instantiate menu-item%
|
|
[(string-append "[" (case (1st mi)
|
|
[(#\space) "SPC"] [(#\return) "RET"]
|
|
[else (string (1st mi))])
|
|
"] " (2nd mi))
|
|
menu
|
|
(lambda (i e)
|
|
(let ([f (3rd mi)])
|
|
((if (symbol? f) (lambda () ((send this get-cell-op f) e)) f))))])
|
|
mi))
|
|
(set! cell-items (map make-item cell-menu-items))
|
|
(instantiate separator-menu-item% (menu))
|
|
(for-each make-item global-menu-items)
|
|
(lambda (cell e x y)
|
|
(set! this cell)
|
|
(let ([ok? (not (null-expr? (send this get-expr)))])
|
|
(for-each (lambda (mi)
|
|
(send (1st mi) enable
|
|
((send cell get-cell-op (4th mi)) 'enabled? e)))
|
|
cell-items))
|
|
(send cell popup-menu menu x y))))
|
|
|
|
(define cells '())
|
|
(define (find-cell x y)
|
|
(let/ec return
|
|
(for-each
|
|
(lambda (c)
|
|
(let-values ([(x y) (send c screen->client x y)])
|
|
(when (and (< -1 x (send c get-width)) (< -1 y (send c get-height)))
|
|
(return c))))
|
|
cells)
|
|
#f))
|
|
|
|
(define current-cell #f)
|
|
|
|
(define cell%
|
|
(class canvas%
|
|
(init-field name expr draggable? dropper alt-func size parent)
|
|
(inherit get-dc)
|
|
(define bitmap (instantiate bitmap% (size size)))
|
|
(define dc (instantiate bitmap-dc% (bitmap)))
|
|
;; general operations
|
|
(define evaluate-next #f)
|
|
(define/private (draw-contents)
|
|
(unhighlight!)
|
|
(set! expr (draw-expr dc expr name evaluate-next))
|
|
(set! evaluate-next #f)
|
|
(on-paint))
|
|
(define/public (get-expr) expr)
|
|
(define/public (set-expr! e) (set-contents! (cons #f e)))
|
|
(define/public (get-contents) (cons name expr))
|
|
(define/public (set-contents! n/e)
|
|
(cond [(eq? dropper 'copy)
|
|
(set! modified? #t)
|
|
(set! name (car n/e))
|
|
(set! expr (cdr n/e))
|
|
(draw-contents)]
|
|
[dropper (dropper n/e)]
|
|
[else #f]))
|
|
(define/public (eval-next-expr) (set! evaluate-next #t))
|
|
(define/public (get-dropper) dropper)
|
|
;; highlighting
|
|
(define/private (frame-xor-bitmap)
|
|
(set-pen/brush dc XOR-PEN/BRUSH)
|
|
(send* dc
|
|
(draw-rectangle 1 1 size size)
|
|
(draw-rectangle CELL-BORDER CELL-BORDER
|
|
(- size CELL-BORDER CELL-BORDER -1)
|
|
(- size CELL-BORDER CELL-BORDER -1)))
|
|
(on-paint))
|
|
(define highlighted? #f)
|
|
(define/public (highlight!)
|
|
(unless highlighted? (frame-xor-bitmap) (set! highlighted? #t)))
|
|
(define/public (unhighlight!)
|
|
(when highlighted? (frame-xor-bitmap) (set! highlighted? #f)))
|
|
;; cell operations
|
|
(define (make-cell-op: op . enabled?)
|
|
(let ([enabled?
|
|
(cond [(null? enabled?) (lambda (e) (not (null-expr? expr)))]
|
|
[(not (procedure? (car enabled?)))
|
|
(lambda (e) (and (car enabled?) (not (null-expr? expr))))]
|
|
[else (car enabled?)])])
|
|
(lambda (e . more)
|
|
(let ([enabled? (enabled? (if (eq? e 'enabled?) (car more) e))])
|
|
(cond [(eq? e 'enabled?) enabled?] [enabled? (op e)])))))
|
|
(define cut:
|
|
(make-cell-op: (lambda (e) (copy: e) (clear: e)) (and dropper #t)))
|
|
(define copy:
|
|
(make-cell-op: (lambda (e)
|
|
(send the-clipboard set-clipboard-string
|
|
(write-to-string (get-contents))
|
|
(send e get-time-stamp)))))
|
|
(define paste:
|
|
(make-cell-op: (lambda (e)
|
|
(set-contents!
|
|
(read-from-string
|
|
(send the-clipboard get-clipboard-string
|
|
(send e get-time-stamp)))))
|
|
(lambda (e)
|
|
(and dropper
|
|
(valid-contents?
|
|
(read-from-string
|
|
(send the-clipboard get-clipboard-string
|
|
(send e get-time-stamp))))))))
|
|
(define clear:
|
|
(make-cell-op: (lambda (e) (set-contents! (cons #f null-expr)))
|
|
(and dropper #t)))
|
|
(define show:
|
|
(make-cell-op: (lambda (e) (unhighlight!) (show-expr expr name))))
|
|
(define print:
|
|
(make-cell-op: (lambda (e) (unhighlight!) (print-expr expr name))))
|
|
(define eval:
|
|
(make-cell-op: (lambda (e) (eval-next-expr) (draw-contents))
|
|
(and dropper #t)))
|
|
(define rename:
|
|
(make-cell-op: (lambda (e)
|
|
(let ([new (get-text-from-user
|
|
"GCalc" "Enter a new name" gcalc-frame
|
|
(or name ""))])
|
|
(when new
|
|
(set! modified? #t)
|
|
(set! name new)
|
|
(draw-contents))))
|
|
(and dropper #t)))
|
|
(define/public (get-cell-op msg)
|
|
(case msg
|
|
[(cut:) cut:] [(copy:) copy:] [(paste:) paste:] [(clear:) clear:]
|
|
[(show:) show:] [(print:) print:] [(eval:) eval:] [(rename:) rename:]))
|
|
;; events
|
|
(define/override (on-paint)
|
|
(send (get-dc) draw-bitmap bitmap 0 0))
|
|
(define right-menu-thread #f)
|
|
(define dragging? #f)
|
|
(define drag-to #f)
|
|
(define last-click-time #f)
|
|
(define/override (on-event e)
|
|
(when (and right-menu-thread (not (send e get-right-down)))
|
|
(kill-thread right-menu-thread)
|
|
(set! right-menu-thread #f))
|
|
(case (send e get-event-type)
|
|
[(enter)
|
|
(set! current-cell this)
|
|
(send this focus)
|
|
(when (and draggable? (not (null-expr? expr)))
|
|
(highlight!))]
|
|
[(leave)
|
|
(unless dragging? (set! current-cell #f) (unhighlight!))]
|
|
[(left-down)
|
|
(let ([d? (and last-click-time
|
|
(< (- (current-milliseconds) last-click-time)
|
|
DOUBLE-MILISECS))])
|
|
(set! last-click-time (if d? #f (current-milliseconds)))
|
|
(if d?
|
|
(show: e)
|
|
(begin (set! dragging? #t) (set! drag-to #f))))]
|
|
[(left-up)
|
|
(set! dragging? #f)
|
|
(when drag-to
|
|
(send drag-to set-contents! (get-contents))
|
|
(when (and (not (send e get-shift-down))
|
|
(not (eq? drag-to main-cell))
|
|
(eq? 'copy (send drag-to get-dropper)))
|
|
(clear: e)))]
|
|
[(right-down)
|
|
(if alt-func
|
|
(set! right-menu-thread
|
|
(thread
|
|
(lambda ()
|
|
(sleep 0.3)
|
|
(queue-callback
|
|
(lambda ()
|
|
(popup-cell-menu this e (send e get-x) (send e get-y))))
|
|
(set! right-menu-thread #f))))
|
|
(popup-cell-menu this e (send e get-x) (send e get-y)))]
|
|
[(right-up)
|
|
(when right-menu-thread
|
|
(kill-thread right-menu-thread)
|
|
(set! right-menu-thread #f))
|
|
(when (and alt-func (not (null-expr? (send main-cell get-expr))))
|
|
(alt-func this))]
|
|
[(middle-down)
|
|
(show: e)]
|
|
[(motion)
|
|
(when dragging?
|
|
(let*-values ([(x y) (send this client->screen
|
|
(send e get-x) (send e get-y))]
|
|
[(c) (find-cell x y)])
|
|
(when (and c (let ([cdrop (send c get-dropper)])
|
|
(or (eq? c this) (not cdrop)
|
|
(and (not (eq? cdrop 'copy))
|
|
(null-expr? (send main-cell get-expr))))))
|
|
(set! c #f))
|
|
(unless (eq? c drag-to)
|
|
(when drag-to (send drag-to unhighlight!))
|
|
(when c (send c highlight!))
|
|
(set! drag-to c))))]))
|
|
(define/override (on-char e)
|
|
(let ([ch (send e get-key-code)])
|
|
(when (eq? this current-cell)
|
|
(cond [(memq ch '(escape f10))
|
|
(popup-cell-menu this e (send e get-x) (send e get-y))]
|
|
[(eq? ch 'f1) (help)]
|
|
[(assq ch cell-menu-items) =>
|
|
(lambda (mi)
|
|
((send this get-cell-op (3rd mi)) e))]
|
|
[(assq ch global-menu-items) =>
|
|
(lambda (mi) ((3rd mi)))]))))
|
|
;; initialization
|
|
(set! cells (cons this cells))
|
|
(when (and (not name) (symbol? expr)) (set! name (symbol->string expr)))
|
|
(super-instantiate (parent))
|
|
(send* this (min-width size) (min-height size))
|
|
(send dc set-text-mode 'solid)
|
|
(send dc set-font CELL-FONT)
|
|
(draw-contents)))
|
|
|
|
(define show-expr
|
|
(let* ([dlg (instantiate dialog% ("GCalc Expression" gcalc-frame)
|
|
(style '(no-caption)))]
|
|
[bmp (instantiate bitmap% (SHOW-CELL-SIZE SHOW-CELL-SIZE))]
|
|
[dc (instantiate bitmap-dc% (bmp))]
|
|
[cnv (instantiate
|
|
(class canvas%
|
|
(inherit get-dc)
|
|
(define/override (on-event e)
|
|
(when (send e button-down?) (send dlg show #f)))
|
|
(define/override (on-char e)
|
|
(unless (memq (send e get-key-code)
|
|
'(release #\nul control shift))
|
|
(send dlg show #f)))
|
|
(define/override (on-paint)
|
|
(send (get-dc) draw-bitmap bmp 0 0))
|
|
(super-instantiate (dlg))
|
|
(send* this
|
|
(min-width SHOW-CELL-SIZE)
|
|
(min-height SHOW-CELL-SIZE)))
|
|
())]
|
|
[cdc (send cnv get-dc)])
|
|
(send dc set-text-mode 'solid)
|
|
(send dc set-font SHOW-FONT)
|
|
(lambda (expr name)
|
|
(draw-expr dc expr name)
|
|
(send dlg show #t))))
|
|
|
|
(define (print-expr expr name)
|
|
(let ([dc (instantiate post-script-dc% ())])
|
|
(send dc start-doc "Printing...")
|
|
(send dc start-page)
|
|
(fluid-let ([BG-PEN/BRUSH (list (instantiate pen% ("BLACK" 1 'solid))
|
|
(instantiate brush% ("WHITE" 'solid)))])
|
|
(if (or NOBMP-PRINT (< (expr-size expr) 5000))
|
|
(draw-expr dc expr name)
|
|
(let* ([size (let-values ([(sx sy) (send dc get-size)])
|
|
(inexact->exact (min sx sy)))]
|
|
[bmp (instantiate bitmap% (size size))]
|
|
[bmpdc (instantiate bitmap-dc% (bmp))])
|
|
(message-box "Printing"
|
|
"The expression, is too complex, using bitmap."
|
|
gcalc-frame '(ok))
|
|
(draw-expr bmpdc expr name)
|
|
(send dc draw-bitmap bmp 0 0))))
|
|
(send dc end-page)
|
|
(send dc end-doc)))
|
|
|
|
(define tiled-panel%
|
|
(class vertical-panel%
|
|
(init-field width size)
|
|
(define current-pane #f)
|
|
(define left 0)
|
|
(define/public (add-cell name expr draggable? dropper . alt-func)
|
|
(set! alt-func (and (not (null? alt-func)) (car alt-func)))
|
|
(when (zero? left)
|
|
(set! current-pane (instantiate horizontal-pane% (this)))
|
|
(set! left width))
|
|
(set! left (sub1 left))
|
|
(instantiate cell%
|
|
(name expr draggable? dropper alt-func size current-pane)))
|
|
(super-instantiate (main-pane) (style '(border)))))
|
|
|
|
;; colors
|
|
(define colors-panel
|
|
(instantiate tiled-panel% (COLOR-CELL-ROW COLOR-CELL-SIZE)))
|
|
(for-each (lambda (x)
|
|
(send colors-panel add-cell #f (car x) #t #f
|
|
(lambda (this)
|
|
(send main-cell set-expr!
|
|
(make-abstraction (send this get-expr)
|
|
(send main-cell get-expr))))))
|
|
COLORS)
|
|
|
|
;; operators
|
|
(define operator-panel
|
|
(instantiate tiled-panel% (OPERS-CELL-ROW OPERS-CELL-SIZE)))
|
|
(define (make-dropper name maker op 1st?)
|
|
(send operator-panel add-cell (string-append " " name " ") #f #f
|
|
(lambda (n/e)
|
|
(when (and EVAL-NOW (eq? op 'apply)) (send main-cell eval-next-expr))
|
|
(send main-cell set-expr!
|
|
(maker (cdr n/e) (send main-cell get-expr))))
|
|
(lambda (this)
|
|
(send main-cell set-expr!
|
|
((if 1st? expr-1st expr-2nd)
|
|
(split-expr (send main-cell get-expr) op))))))
|
|
(make-dropper "Back" make-back-front '/ #t)
|
|
(make-dropper "Top" make-top-bottom '- #f)
|
|
(make-dropper "Apply (func)" make-application1 'apply #f)
|
|
(make-dropper "Left" make-left-right '\| #f)
|
|
(define main-cell (send operator-panel add-cell " Main " #f #t 'copy))
|
|
(make-dropper "Right" make-right-left '\| #t)
|
|
(make-dropper "Apply (arg)" make-application2 'apply #t)
|
|
(make-dropper "Bottom" make-bottom-top '- #t)
|
|
(make-dropper "Front" make-front-back '/ #f)
|
|
(send main-cell focus)
|
|
|
|
;; storage
|
|
(define store-panel
|
|
(instantiate tiled-panel% (STORE-CELL-ROW STORE-CELL-SIZE)))
|
|
(define storage-cells
|
|
(let loop ([n (* STORE-CELL-ROW STORE-CELL-COL)] [cells '()])
|
|
(if (zero? n)
|
|
(reverse cells)
|
|
(loop (sub1 n)
|
|
(cons (send store-panel add-cell #f #f #t 'copy) cells)))))
|
|
(define (get-storage-contents)
|
|
(map (lambda (c) (send c get-contents)) storage-cells))
|
|
(define (set-storage-contents! names/exprs)
|
|
(for-each (lambda (c n/e) (send c set-contents! n/e))
|
|
storage-cells names/exprs))
|
|
|
|
;; start the whole thing
|
|
(send gcalc-frame show #t)
|
|
|
|
))
|