suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Avoid using a xor brush for highlights.

Browse Source
This commit is contained in:
Eli Barzilay 2011-02-14 13:34:01 -05:00
parent 8d211cd048
commit 0a2d5fd4ac
1 changed files with 18 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/games/gcalc/gcalc.rkt
View File

@ -1,7 +1,7 @@
;;;============================================================================ ;;;============================================================================
;;; GCalc ;;; GCalc
;;; based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html ;;; based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
;;; implemented by Eli Barzilay: Maze is Life! (eli@barzilay.org) ;;; implemented by Eli Barzilay.
#lang mzscheme #lang mzscheme
@ -25,7 +25,7 @@
(defcustom EVAL-NOW #t 'bool "Evaluate immediately on application") (defcustom EVAL-NOW #t 'bool "Evaluate immediately on application")
(defcustom EVAL-DEPTH 18 '(int 100) "Evaluation depth limit") (defcustom EVAL-DEPTH 18 '(int 100) "Evaluation depth limit")
(defcustom DRAW-CUTOFF 8 '(int 50) "Cutoff evaluation when smaller") (defcustom DRAW-CUTOFF 8 '(int 50) "Cutoff evaluation when smaller")
(defcustom SPLIT-ARGS #f 'bool "Split arg by function body structure") (defcustom SPLIT-ARGS #f 'bool "Split arg by function body structure")
(defcustom COLOR-OPS #f 'bool "Use colors as functions") (defcustom COLOR-OPS #f 'bool "Use colors as functions")
(defcustom NOBMP-PRINT #f 'bool "Never use bitmaps to print") (defcustom NOBMP-PRINT #f 'bool "Never use bitmaps to print")
@ -76,10 +76,12 @@
(define SHOW-CELL-SIZE 600) (define SHOW-CELL-SIZE 600)
(define BG-PEN/BRUSH (list (instantiate pen% ["BLACK" 1 'solid]) (define BG-PEN/BRUSH (list (instantiate pen% ["BLACK" 1 'solid])
(instantiate brush% ["GRAY" 'solid]))) (instantiate brush% ["GRAY" 'solid])))
(define XOR-PEN/BRUSH (list (instantiate pen% ["BLACK" 0 'xor]) (define HIGHLIGHT-WIDTH 4)
(instantiate brush% ["BLACK" 'xor]))) (define HIGHLIGHT-PEN/BRUSH
(list (instantiate pen% ["BLACK" HIGHLIGHT-WIDTH 'solid])
(instantiate brush% ("BLACK" 'transparent))))
(define DOUBLE-MILISECS 250) (define DOUBLE-MILISECS 250)
@ -755,19 +757,11 @@
(define/public (eval-next-expr) (set! evaluate-next #t)) (define/public (eval-next-expr) (set! evaluate-next #t))
(define/public (get-dropper) dropper) (define/public (get-dropper) dropper)
;; highlighting ;; 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 highlighted? #f)
(define/public (highlight!) (define/public (highlight!)
(unless highlighted? (frame-xor-bitmap) (set! highlighted? #t))) (unless highlighted? (set! highlighted? #t) (on-paint)))
(define/public (unhighlight!) (define/public (unhighlight!)
(when highlighted? (frame-xor-bitmap) (set! highlighted? #f))) (when highlighted? (set! highlighted? #f) (on-paint)))
;; cell operations ;; cell operations
(define (make-cell-op: op . enabled?) (define (make-cell-op: op . enabled?)
(let ([enabled? (let ([enabled?
@ -823,7 +817,13 @@
[(show:) show:] [(print:) print:] [(eval:) eval:] [(rename:) rename:])) [(show:) show:] [(print:) print:] [(eval:) eval:] [(rename:) rename:]))
;; events ;; events
(define/override (on-paint) (define/override (on-paint)
(send (get-dc) draw-bitmap bitmap 0 0)) (let ([dc (get-dc)])
(send dc draw-bitmap bitmap 0 0)
(when highlighted?
(set-pen/brush dc HIGHLIGHT-PEN/BRUSH)
(let ([w1 (round (/ HIGHLIGHT-WIDTH 2))]
[w2 (- size HIGHLIGHT-WIDTH -1)])
(send dc draw-rectangle w1 w1 w2 w2)))))
(define right-menu-thread #f) (define right-menu-thread #f)
(define dragging? #f) (define dragging? #f)
(define drag-to #f) (define drag-to #f)
@ -836,8 +836,7 @@
[(enter) [(enter)
(set! current-cell this) (set! current-cell this)
(send this focus) (send this focus)
(when (and draggable? (not (null-expr? expr))) (when (and draggable? (not (null-expr? expr))) (highlight!))]
(highlight!))]
[(leave) [(leave)
(unless dragging? (set! current-cell #f) (unhighlight!))] (unless dragging? (set! current-cell #f) (unhighlight!))]
[(left-down) [(left-down)