From 95abacd088aed08d3a35384b12a7e5555ce40a30 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 7 Mar 2013 16:16:33 -0500 Subject: [PATCH] GCalc updates. * Lots of racket-isms. * Add ".rktd" to the sample file. * Fix an old bug where the large display wouldn't get refreshed. --- .../{gcalc-examples => gcalc-examples.rktd} | 0 collects/games/gcalc/gcalc.rkt | 768 +++++++++--------- 2 files changed, 372 insertions(+), 396 deletions(-) rename collects/games/gcalc/{gcalc-examples => gcalc-examples.rktd} (100%) diff --git a/collects/games/gcalc/gcalc-examples b/collects/games/gcalc/gcalc-examples.rktd similarity index 100% rename from collects/games/gcalc/gcalc-examples rename to collects/games/gcalc/gcalc-examples.rktd diff --git a/collects/games/gcalc/gcalc.rkt b/collects/games/gcalc/gcalc.rkt index 42016e089a..820e397469 100644 --- a/collects/games/gcalc/gcalc.rkt +++ b/collects/games/gcalc/gcalc.rkt @@ -16,7 +16,7 @@ (syntax-rules () [(_ var default type description) (begin (define var default) - (add-custom! 'var (lambda () var) (lambda (v) (set! var v)) + (add-custom! 'var (λ() var) (λ(v) (set! var v)) type description))])) (define game@ (unit (import) (export) @@ -30,37 +30,37 @@ (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 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)))) + (let ([cs '((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))]) + (for/list ([c (in-list cs)]) + (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])))))) (define COLOR-CELL-ROW 2) (define COLOR-CELL-COL (/ (length COLORS) COLOR-CELL-ROW)) @@ -76,19 +76,20 @@ (define SHOW-CELL-SIZE 600) -(define BG-PEN/BRUSH (make-parameter (list (instantiate pen% ["BLACK" 1 'solid]) - (instantiate brush% ["GRAY" 'solid])))) +(define BG-PEN/BRUSH + (make-parameter (list (instantiate pen% ["BLACK" 1 'solid]) + (instantiate brush% ["GRAY" 'solid])))) (define HIGHLIGHT-WIDTH 4) (define HIGHLIGHT-PEN/BRUSH - (list (instantiate pen% ["BLACK" HIGHLIGHT-WIDTH 'solid]) - (instantiate brush% ("BLACK" 'transparent)))) + (list (instantiate pen% ["BLACK" HIGHLIGHT-WIDTH 'solid]) + (instantiate brush% ["BLACK" 'transparent]))) (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 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) @@ -106,9 +107,9 @@ (define 4th cadddr) (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))))) + (with-handlers ([void (λ(x) #f)]) + (define obj (read (open-input-string (string-append "(" str ")")))) + (and (list? obj) (= 1 (length obj)) (car obj)))) (define (write-to-string obj) (format "~s" obj)) @@ -195,23 +196,22 @@ (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)))] + (define 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)))])))) + [else (for/vector ([c1 (in-list rgb1)] [c2 (in-list rgb2)]) + (inexact->exact (round (/ (+ c1 c2) 2))))])) + (define rgb (get-rgb color)) + (let loop ([expr expr]) + (cond [(or (var-expr? expr) (null-expr? expr)) expr] + [(simple-expr? expr) (mix rgb (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) @@ -222,17 +222,17 @@ (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))))])))) + (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)) @@ -243,34 +243,32 @@ #; ;; 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)))])) + (cond [(zero? level) null-expr] + [(or (simple-expr? expr) (abstraction-expr? expr)) expr] + [(application-expr? expr) + (define 1st (eval-expr (expr-1st expr) (sub1 level))) + (define 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 (define 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))) + (λ() (eval-expr expr (or EVAL-DEPTH -1))) end-busy-cursor)) (define (split-expr expr op) @@ -278,15 +276,14 @@ [(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)))])) + [else (define e1 (split-expr (expr-1st expr) op)) + (define e2 (split-expr (expr-2nd expr) op)) + (define e11 (expr-1st e1)) + (define e12 (expr-2nd e1)) + (define e21 (expr-1st e2)) + (define e22 (expr-2nd e2)) + (define 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 @@ -316,8 +313,7 @@ [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)))]) + (let ([ok? (λ(x) (and (integer? x) (<= 0 x 255)))]) (and (ok? (vector-ref obj 0)) (ok? (vector-ref obj 1)) (ok? (vector-ref obj 2)))))] @@ -343,15 +339,15 @@ (and (var-expr? expr) (eq? (var-val expr) 'transparent))) (let ([v (hash-ref 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-set! transparent?-cache expr v) - v) - v)))) + (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-set! transparent?-cache expr v) + v) + v)))) ;; Draw an exprression - the smart way. (define (draw-expr dc expr name . r) @@ -363,10 +359,10 @@ (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% ())] + (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) + (λ(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)))) @@ -377,68 +373,72 @@ (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 + [(null-expr? expr) expr] + [(composite-expr? expr) + (define 1st (expr-1st expr)) + (define 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))))] + (define cut? (and DRAW-CUTOFF (< (* (- x2 x1) size) DRAW-CUTOFF))) + (define x12 (avg x1 x2)) + (define 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))))] + (define cut? (and DRAW-CUTOFF (< (* (- y2 y1) size) DRAW-CUTOFF))) + (define y12 (avg y1 y2)) + (define 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))))] + (define cut? (and DRAW-CUTOFF (< (* (- z2 z1) size) DRAW-CUTOFF))) + (define z12 (avg z1 z2)) + (define 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)) + (define xx (+ (rnd (* (+ x1 (* (- x2 x1) abstr) (* 3D-DX z2)) + (/ dc-size (+ 1 3D-DX)))) + dc-ofs)) + (define yy (+ (rnd (* (+ y1 (* 3D-DY z2)) (/ dc-size (+ 1 3D-DY)))) + dc-ofs)) + (define dx (rnd (* ABSTR-SIZE (- x2 x1) (/ dc-size (+ 1 3D-DX))))) + (define 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)]))] + (define x12 (avg x1 x2)) + (define y12 (avg y1 y2)) + (define dx (* (- x2 x1) 1/2 APPLY-SIZE)) + (define dy (* (- y2 y1) 1/2 APPLY-SIZE)) + (define xx1 (- x12 dx)) + (define yy1 (- y12 dy)) + (define xx2 (+ x12 dx)) + (define yy2 (+ y12 dy)) + (define zz (* (- z2 z1) APPLY-SIZE)) + (define z11 (+ z1 zz)) + (define 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* (;; @@ -494,19 +494,17 @@ [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)) + (λ() (send dc clear) + (set-pen/brush dc (BG-PEN/BRUSH)) + (send dc draw-rectangle 1 1 size size) + (begin0 (draw expr (if eval? EVAL-DEPTH 0) + #t #t #t .0 .0 .0 1.0 1.0 1.0 .0) + (when name + (define-values [tw th d a] (send dc get-text-extent name)) + (define 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)))) end-busy-cursor)) ;;;============================================================================ @@ -517,13 +515,13 @@ (class frame% (define/augment (on-close) (maybe-save-and-exit)) (define/public (open-file file) (open file)) - (super-instantiate ("GCalc") (style '(no-resize-border))) + (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))) + (instantiate horizontal-pane% [gcalc-frame])) (define help (show-scribbling @@ -540,70 +538,64 @@ (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))))) + (λ() (dynamic-wind + begin-busy-cursor + (λ() (define (out x) (write x) (newline)) + (out "GCALC") + (for ([c (in-list customs)]) (out ((custom-getter c)))) + (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 (collection-file-path "gcalc-examples" "games" "gcalc" ))))) + (open (path->string (collection-file-path "gcalc-examples.rktd" + "games" "gcalc")))) -(define (open . file) +(define (open [file (void)]) (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 f + (if (not (void? file)) + file + (cond [(get-file "Open" gcalc-frame) => path->string] [else #f]))) + (when f + (if (file-exists? f) + (with-input-from-file f + (λ() (dynamic-wind + begin-busy-cursor + (λ() (with-handlers + ([exn:fail? + (λ(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 ([c (in-list customs)]) ((custom-setter c) (read))) + (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 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))))) + (begin (bell) + (eq? 'yes (message-box "GCalc" "Save modifications?" + gcalc-frame '(yes-no))))) (save))) (define (maybe-save-and-exit) (maybe-save) @@ -611,64 +603,61 @@ (send gcalc-frame show #f)) (define set-options - (let ([dlg (instantiate dialog% ("GCalc Expression" gcalc-frame))]) + (let ([dlg (instantiate dialog% ["GCalc Expression" gcalc-frame])]) (define ok? #f) - (define inits (lambda () (set! ok? #f))) - (define finals (lambda () (set! modified? #t))) + (define inits (λ() (set! ok? #f))) + (define finals (λ() (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))))) + (let ([c inits]) (set! inits (λ() (initializer) (c)))) + (let ([c finals]) (set! finals (λ() (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 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 cb (instantiate check-box% [title (new-row) void])) + (add-init/final (λ() (send cb set-value (getter))) + (λ() (setter (send cb get-value))))) (define (make-check/slide getter setter title range) (define row (new-row)) (define toggle (instantiate check-box% - (title row + [title row (let ([saved 0]) - (lambda (this e) + (λ(this e) (if (send this get-value) (send slider set-value saved) (begin (set! saved (send slider get-value)) - (send slider set-value 0)))))))) + (send slider set-value 0)))))])) (define slider (instantiate slider% ["" 0 range row - (lambda (this e) + (λ(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)))))) + (add-init/final (λ() (define val (getter)) + (send slider set-value (or val 0)) + (send toggle set-value (and val #t))) + (λ() (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))] + ["&OK" row (λ(this e) (set! ok? #t) (send dlg show #f))] [style '(border)]) (instantiate button% - ["&Cancel" row (lambda (this e) (send dlg show #f))]))) + ["&Cancel" row (λ(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) + (for ([c (in-list customs)]) + (define type (custom-type c)) + (define getter (custom-getter c)) + (define setter (custom-setter c)) + (define 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))])) (make-ok-cancel) ;; Main - (lambda () (inits) (send dlg show #t) (when ok? (finals))))) + (λ() (inits) (send dlg show #t) (when ok? (finals))))) (define cell-menu-items `((#\x "C&ut" cut:) (#\c "&Copy" copy:) @@ -698,32 +687,25 @@ [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))))]) + (λ(i e) + (define f (3rd mi)) + ((if (symbol? f) (λ() ((send this get-cell-op f) e)) f)))]) mi)) (set! cell-items (map make-item cell-menu-items)) - (instantiate separator-menu-item% (menu)) + (instantiate separator-menu-item% [menu]) (for-each make-item global-menu-items) - (lambda (cell e x y) + (λ(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)) + (define ok? (not (null-expr? (send this get-expr)))) + (for ([ci (in-list cell-items)]) + (send (1st ci) enable ((send cell get-cell-op (4th ci)) 'enabled? e))) (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)) + (for/or ([c (in-list cells)]) + (define-values [x* y*] (send c screen->client x y)) + (and (< -1 x* (send c get-width)) (< -1 y* (send c get-height)) c))) (define current-cell #f) @@ -731,8 +713,8 @@ (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))) + (define bitmap (instantiate bitmap% [size size])) + (define dc (instantiate bitmap-dc% [bitmap])) ;; general operations (define evaluate-next #f) (define/private (draw-contents) @@ -762,51 +744,47 @@ ;; cell operations (define (make-cell-op: op . enabled?) (let ([enabled? - (cond [(null? enabled?) (lambda (e) (not (null-expr? expr)))] + (cond [(null? enabled?) (λ(e) (not (null-expr? expr)))] [(not (procedure? (car enabled?))) - (lambda (e) (and (car enabled?) (not (null-expr? expr))))] + (λ(e) (and (car enabled?) (not (null-expr? expr))))] [else (car enabled?)])]) - (lambda (e . more) + (λ(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))) + (make-cell-op: (λ(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))))) + (make-cell-op: (λ(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)))))))) + (make-cell-op: (λ(e) (set-contents! + (read-from-string + (send the-clipboard get-clipboard-string + (send e get-time-stamp))))) + (λ(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))) + (make-cell-op: (λ(e) (set-contents! (cons #f null-expr))) (and dropper #t))) (define show: - (make-cell-op: (lambda (e) (unhighlight!) (show-expr expr name)))) + (make-cell-op: (λ(e) (unhighlight!) (show-expr expr name)))) (define print: - (make-cell-op: (lambda (e) (unhighlight!) (print-expr expr name)))) + (make-cell-op: (λ(e) (unhighlight!) (print-expr expr name)))) (define eval: - (make-cell-op: (lambda (e) (eval-next-expr) (draw-contents)) + (make-cell-op: (λ(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)))) + (make-cell-op: (λ(e) (define 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 @@ -856,12 +834,11 @@ (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)))) + (λ() (sleep 0.3) + (queue-callback + (λ() (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 @@ -891,67 +868,67 @@ (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)))])))) + [(assq ch cell-menu-items) + => (λ(mi) ((send this get-cell-op (3rd mi)) e))] + [(assq ch global-menu-items) + => (λ(mi) ((3rd mi)))])))) ;; initialization (set! cells (cons this cells)) (when (and (not name) (symbol? expr)) (set! name (symbol->string expr))) - (super-instantiate (parent)) + (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) + (let ([dlg (instantiate dialog% ["GCalc Expression" gcalc-frame] + [style '(no-caption)])]) + (define bmp (instantiate bitmap% [SHOW-CELL-SIZE SHOW-CELL-SIZE])) + (define dc (instantiate bitmap-dc% [bmp])) + (define 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))) + [])) + (define cdc (send cnv get-dc)) + (define last-expr #f) + (λ(expr name) + (send dc set-text-mode 'solid) + (send dc set-font SHOW-FONT) + (unless (eq? last-expr expr) + (draw-expr dc expr name) + (set! last-expr expr)) + (send cdc draw-bitmap bmp 0 0) (send dlg show #t)))) (define (print-expr expr name) - (let ([dc (instantiate post-script-dc% ())]) - (send dc start-doc "Printing...") - (send dc start-page) - (parameterize ([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 dc (instantiate post-script-dc% [])) + (send dc start-doc "Printing...") + (send dc start-page) + (parameterize ([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% @@ -961,34 +938,33 @@ (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! 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))))) + [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) + (instantiate tiled-panel% [COLOR-CELL-ROW COLOR-CELL-SIZE])) +(for ([c (in-list COLORS)]) + (send colors-panel add-cell #f (car c) #t #f + (λ(this) + (send main-cell set-expr! + (make-abstraction (send this get-expr) + (send main-cell get-expr)))))) ;; operators (define operator-panel - (instantiate tiled-panel% (OPERS-CELL-ROW OPERS-CELL-SIZE))) + (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) + (λ(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) + (λ(this) (send main-cell set-expr! ((if 1st? expr-1st expr-2nd) (split-expr (send main-cell get-expr) op)))))) @@ -1005,7 +981,7 @@ ;; storage (define store-panel - (instantiate tiled-panel% (STORE-CELL-ROW STORE-CELL-SIZE))) + (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) @@ -1013,10 +989,10 @@ (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)) + (for/list ([c (in-list storage-cells)]) (send c get-contents))) (define (set-storage-contents! names/exprs) - (for-each (lambda (c n/e) (send c set-contents! n/e)) - storage-cells names/exprs)) + (for ([c (in-list storage-cells)] [n/e (in-list names/exprs)]) + (send c set-contents! n/e))) ;; start the whole thing (send gcalc-frame show #t)