From b77d7e324f0eee55a373fcad1d6bb3698cf6b8bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 Aug 2002 18:04:52 +0000 Subject: [PATCH] .. original commit: 6567aaadd49dde062ad045f1c98c9463d55f6cb1 --- collects/framework/decorated-editor-snip.ss | 161 ++++++++++++++++++++ collects/framework/framework.ss | 4 +- 2 files changed, 164 insertions(+), 1 deletion(-) create mode 100644 collects/framework/decorated-editor-snip.ss diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss new file mode 100644 index 00000000..14e70b9b --- /dev/null +++ b/collects/framework/decorated-editor-snip.ss @@ -0,0 +1,161 @@ +(module decorated-editor-snip mzscheme + (provide decorated-editor-snip% + decorated-editor-snipclass%) + + (require (lib "class.ss") + (lib "mred.ss" "mred")) + + (define decorated-editor-snip% + (class editor-snip% + (inherit get-editor get-style) + + ;; get-color : -> (union string (is-a?/c color%)) + (define/public (get-color) (error 'get-color "abstract method")) + + ;; get-menu : -> (is-a?/c popup-menu%) + ;; returns the popup menu that should appear + ;; when clicking in the top part of the snip. + (define/public (get-menu) + (error 'get-menu "absract method")) + + ;; make-snip : -> this% + ;; returns an instance of this class. used in the copy method + (define/public (make-snip) + (error 'make-snip "abstract method")) + + ;; make-editor : -> editor<%> + ;; returns the editor to be used in this snip. + (define/public (make-editor) + (error 'make-editor "abstract method in XML/Scheme box superclass")) + + ;; get-corner-bitmap : -> (is-a?/c bitmap%) + ;; returns the bitmap to be shown in the top right corner. + (define/public (get-corner-bitmap) + (error 'get-corner-bitmap "abstract method")) + + [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)] + [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] + + (inherit get-admin) + (rename [super-on-event on-event]) + (define/override (on-event dc x y editorx editory evt) + (let ([sx (- (send evt get-x) x)] + [sy (- (send evt get-y) y)] + [bil (box 0)] + [bit (box 0)] + [bir (box 0)] + [bib (box 0)] + [bw (box 0)] + [bh (box 0)] + [bml (box 0)] + [bmt (box 0)] + [bmr (box 0)] + [bmb (box 0)]) + (get-extent dc x y bw bh #f #f #f #f) + (get-inset bil bit bir bib) + (get-margin bml bmt bmr bmb) + (cond + [(and (send evt get-right-down) + (<= 0 sx (unbox bw)) + (<= 0 sy (unbox bmt))) + (let ([admin (get-admin)] + [menu (get-menu)]) + (send admin popup-menu menu this (+ sx 1) (+ sy 1)))] + [else + (super-on-event dc x y editorx editory evt)]))) + + (inherit get-extent get-inset) + (rename [super-draw draw]) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([bil (box 0)] + [bit (box 0)] + [bir (box 0)] + [bib (box 0)] + [bw (box 0)] + [bh (box 0)] + [bml (box 0)] + [bmt (box 0)] + [bmr (box 0)] + [bmb (box 0)]) + (get-extent dc x y bw bh #f #f #f #f) + (get-inset bil bit bir bib) + (get-margin bml bmt bmr bmb) + (super-draw dc x y left top right bottom dx dy draw-caret) + (let* ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [bm (get-corner-bitmap)] + [bm-w (send bm get-width)] + [bm-h (send bm get-height)]) + + (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid)) + (send dc draw-rectangle + (+ x (unbox bml)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bml) (unbox bmr))) + (- (unbox bmt) (unbox bit))) + + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) + (send dc draw-bitmap + bm + (+ x (max 0 + (- (unbox bw) + (unbox bmr) + bm-w))) + ;; leave two pixels above and two below (see super-instantiate below) + (+ y (unbox bit) 2)) + + (send dc set-pen (get-pen)) + (send dc set-brush (get-brush)) + (send dc draw-rectangle + (+ x (unbox bil)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bil) (unbox bir))) + (max 0 (- (unbox bh) (unbox bit) (unbox bib)))) + + + (send dc set-pen old-pen) + (send dc set-brush old-brush)))) + + (define/override write + (lambda (stream-out) + (send (get-editor) write-to-file stream-out 0 'eof))) + + (define/override (copy) + (let ([snip (make-snip)]) + (send snip set-editor (send (get-editor) copy-self)) + (send snip set-style (get-style)) + snip)) + + (inherit set-min-width get-margin) + (define/public (reset-min-width) + (let ([lib (box 0)] + [rib (box 0)] + [lmb (box 0)] + [rmb (box 0)]) + (get-inset lib (box 0) rib (box 0)) + (get-margin lmb (box 0) rmb (box 0)) + (set-min-width + (max 0 (send (get-corner-bitmap) get-width))))) + + (super-instantiate () + (editor (make-editor)) + (with-border? #f) + (top-margin (+ 4 (send (get-corner-bitmap) get-height)))) + + (reset-min-width))) + + (define decorated-editor-snipclass% + (class snip-class% + + ;; make-snip : stream-in -> (is-a?/c snip%) + ;; returns an unfilled version of the snip + (define/public (make-snip stream-in) + (error 'create-snip "abstract method")) + + (define/override (read stream-in) + (let ([snip (make-snip stream-in)]) + (send (send snip get-editor) read-from-file stream-in) + snip)) + (super-instantiate ())))) \ No newline at end of file diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 85381488..d2219578 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -6,6 +6,7 @@ "test.ss" "gui-utils.ss" + "decorated-editor-snip.ss" "framework-unit.ss" "framework-sig.ss" @@ -17,7 +18,8 @@ (provide (all-from "macro.ss") (all-from "test.ss") - (all-from "gui-utils.ss")) + (all-from "gui-utils.ss") + (all-from "decorated-editor-snip.ss")) (provide exn:struct:unknown-preference exn:struct:exn)