moving to school
svn: r9561 original commit: d08039585bc8363374b1ce57102336963aa96126
This commit is contained in:
Robby Findler
parent
4ed12b3ae6
commit
02c6d6f3e9
|
|
@ -1,229 +1,241 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module decorated-editor-snip mzscheme
|
||||
(provide decorated-editor-snip%
|
||||
decorated-editor-snipclass%
|
||||
decorated-editor-snip-mixin)
|
||||
(require scheme/gui/base
|
||||
scheme/class)
|
||||
|
||||
(require mzlib/class
|
||||
mred
|
||||
"preferences.ss")
|
||||
|
||||
(define (decorated-editor-snip-mixin super%)
|
||||
(class super%
|
||||
|
||||
;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
|
||||
;; returns the bitmap to be shown in the top right corner.
|
||||
(define/public (get-corner-bitmap) #f)
|
||||
|
||||
;; get-color : -> (union string (is-a?/c color%))
|
||||
(define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
|
||||
|
||||
;; get-menu : -> (union #f (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) #f)
|
||||
#;
|
||||
(provide editor-snip:decorated%
|
||||
editor-snip:decorated-snipclass
|
||||
editor-snip:decorated-editor-snip-mixin
|
||||
decorated-editor-snip<%>)
|
||||
|
||||
;; get-position : -> (union 'top-right 'left-top)
|
||||
;; returns the location of the image and the clickable
|
||||
;; region. 'top-right indicates top portion is clickable
|
||||
;; and icon on right. 'left-top means left portion is
|
||||
;; clickable and icon on top.
|
||||
(define/public (get-position) 'top-right)
|
||||
|
||||
[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)
|
||||
(define/override (on-event dc x y editorx editory evt)
|
||||
(cond
|
||||
[(eq? (send evt get-event-type) 'right-down)
|
||||
(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)]
|
||||
[menu (get-menu)])
|
||||
(get-extent dc x y bw bh #f #f #f #f)
|
||||
(get-inset bil bit bir bib)
|
||||
(get-margin bml bmt bmr bmb)
|
||||
(let ([in-range
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(and (<= 0 sx (unbox bw))
|
||||
(<= 0 sy (unbox bmt)))]
|
||||
[(left-top)
|
||||
(and (<= 0 sx (unbox bml))
|
||||
(<= 0 sy (unbox bh)))]
|
||||
[else #f])])
|
||||
(cond
|
||||
[(and menu in-range)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
|
||||
[else (super on-event dc x y editorx editory evt)])))]
|
||||
[else
|
||||
(super on-event dc x y editorx editory evt)]))
|
||||
|
||||
(inherit get-extent get-inset)
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let ([bm (get-corner-bitmap)]
|
||||
[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)]
|
||||
[white-on-black? (preferences:get 'framework:white-on-black?)])
|
||||
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen
|
||||
(provide decorated-editor-snip%
|
||||
decorated-editor-snipclass%
|
||||
decorated-editor-snip-mixin
|
||||
decorated-editor-snip<%>)
|
||||
|
||||
(require "preferences.ss")
|
||||
|
||||
(define decorated-editor-snip<%>
|
||||
(interface ((class->interface editor-snip%))
|
||||
get-corner-bitmap get-color get-menu get-position reset-min-sizes))
|
||||
|
||||
(define decorated-editor-snip-mixin
|
||||
(mixin ((class->interface editor-snip%)) (decorated-editor-snip<%>)
|
||||
|
||||
;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
|
||||
;; returns the bitmap to be shown in the top right corner.
|
||||
(define/public (get-corner-bitmap) #f)
|
||||
|
||||
;; get-color : -> (union string (is-a?/c color%))
|
||||
(define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
|
||||
|
||||
;; get-menu : -> (union #f (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) #f)
|
||||
|
||||
;; get-position : -> (union 'top-right 'left-top)
|
||||
;; returns the location of the image and the clickable
|
||||
;; region. 'top-right indicates top portion is clickable
|
||||
;; and icon on right. 'left-top means left portion is
|
||||
;; clickable and icon on top.
|
||||
(define/public (get-position) 'top-right)
|
||||
|
||||
[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)
|
||||
(define/override (on-event dc x y editorx editory evt)
|
||||
(cond
|
||||
[(eq? (send evt get-event-type) 'right-down)
|
||||
(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)]
|
||||
[menu (get-menu)])
|
||||
(get-extent dc x y bw bh #f #f #f #f)
|
||||
(get-inset bil bit bir bib)
|
||||
(get-margin bml bmt bmr bmb)
|
||||
(let ([in-range
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(and (<= 0 sx (unbox bw))
|
||||
(<= 0 sy (unbox bmt)))]
|
||||
[(left-top)
|
||||
(and (<= 0 sx (unbox bml))
|
||||
(<= 0 sy (unbox bh)))]
|
||||
[else #f])])
|
||||
(cond
|
||||
[(and menu in-range)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
|
||||
[else (super on-event dc x y editorx editory evt)])))]
|
||||
[else
|
||||
(super on-event dc x y editorx editory evt)]))
|
||||
|
||||
(inherit get-extent get-inset)
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let ([bm (get-corner-bitmap)]
|
||||
[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)]
|
||||
[white-on-black? (preferences:get 'framework:white-on-black?)])
|
||||
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen
|
||||
(if white-on-black? "black" "white")
|
||||
1
|
||||
'transparent))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush
|
||||
(if white-on-black? "black" "white")
|
||||
1
|
||||
'transparent))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush
|
||||
(if white-on-black? "black" "white")
|
||||
'solid))
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bml))
|
||||
(+ y (unbox bit))
|
||||
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
|
||||
(- (unbox bmt) (unbox bit)))]
|
||||
[(left-top)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bil))
|
||||
(+ y (unbox bmt))
|
||||
(- (unbox bml) (unbox bil))
|
||||
(max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
|
||||
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen
|
||||
(if white-on-black? "white" "black")
|
||||
1
|
||||
'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush
|
||||
(if white-on-black? "white" "black")
|
||||
'solid))
|
||||
|
||||
(when bm
|
||||
(let ([bm-w (send bm get-width)]
|
||||
[bm-h (send bm get-height)])
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(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))]
|
||||
[(left-top)
|
||||
(send dc draw-bitmap
|
||||
bm
|
||||
;; leave two pixels left and two right (see super-instantiate below)
|
||||
(+ x (unbox bil) 2)
|
||||
(+ y (unbox bmt)))])))
|
||||
|
||||
(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))))
|
||||
|
||||
(inherit set-min-width set-min-height get-margin)
|
||||
(define/public (reset-min-sizes)
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bml))
|
||||
(+ y (unbox bit))
|
||||
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
|
||||
(- (unbox bmt) (unbox bit)))]
|
||||
[(left-top)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bil))
|
||||
(+ y (unbox bmt))
|
||||
(- (unbox bml) (unbox bil))
|
||||
(max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
|
||||
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen
|
||||
(if white-on-black? "white" "black")
|
||||
1
|
||||
'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush
|
||||
(if white-on-black? "white" "black")
|
||||
'solid))
|
||||
|
||||
(when bm
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(set-min-width (+ 4 (send bm get-width)))]
|
||||
[(left-top)
|
||||
(set-min-height (+ 4 (send bm get-height)))]))))
|
||||
|
||||
(let ([top-margin
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-height)
|
||||
0)))]
|
||||
[else 4])]
|
||||
[left-margin
|
||||
(case (get-position)
|
||||
[(left-top)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-width)
|
||||
0)))]
|
||||
[else 4])])
|
||||
(super-new
|
||||
(with-border? #f)
|
||||
(top-margin top-margin)
|
||||
(left-margin left-margin)))
|
||||
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t)
|
||||
|
||||
(reset-min-sizes)))
|
||||
|
||||
(define decorated-editor-snip%
|
||||
(class (decorated-editor-snip-mixin editor-snip%)
|
||||
(inherit get-editor get-style)
|
||||
|
||||
;; make-snip : -> this%
|
||||
;; returns an instance of this class. used in the copy method
|
||||
(define/public (make-snip) (make-object decorated-editor-snip%))
|
||||
|
||||
;; make-editor : -> editor<%>
|
||||
;; returns the editor to be used in this snip.
|
||||
(define/public (make-editor) (make-object text%))
|
||||
|
||||
(define/override write
|
||||
(λ (stream-out)
|
||||
(send (get-editor) write-to-file stream-out 0 'eof)))
|
||||
(let ([bm-w (send bm get-width)]
|
||||
[bm-h (send bm get-height)])
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(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))]
|
||||
[(left-top)
|
||||
(send dc draw-bitmap
|
||||
bm
|
||||
;; leave two pixels left and two right (see super-instantiate below)
|
||||
(+ x (unbox bil) 2)
|
||||
(+ y (unbox bmt)))])))
|
||||
|
||||
(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))))
|
||||
|
||||
(inherit set-min-width set-min-height get-margin)
|
||||
(define/public (reset-min-sizes)
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(when bm
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(set-min-width (+ 4 (send bm get-width)))]
|
||||
[(left-top)
|
||||
(set-min-height (+ 4 (send bm get-height)))]))))
|
||||
|
||||
(let ([top-margin
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-height)
|
||||
0)))]
|
||||
[else 4])]
|
||||
[left-margin
|
||||
(case (get-position)
|
||||
[(left-top)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-width)
|
||||
0)))]
|
||||
[else 4])])
|
||||
(super-new
|
||||
(with-border? #f)
|
||||
(top-margin top-margin)
|
||||
(left-margin left-margin)))
|
||||
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t)
|
||||
|
||||
(reset-min-sizes)))
|
||||
|
||||
(define/override (copy)
|
||||
(let ([snip (make-snip)])
|
||||
(send snip set-editor (send (get-editor) copy-self))
|
||||
(send snip set-style (get-style))
|
||||
snip))
|
||||
|
||||
(super-new
|
||||
(editor (make-editor)))))
|
||||
|
||||
(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) (make-object decorated-editor-snip%))
|
||||
|
||||
(define/override (read stream-in)
|
||||
(let ([snip (make-snip stream-in)])
|
||||
(send (send snip get-editor) read-from-file stream-in #f)
|
||||
snip))
|
||||
(super-new))))
|
||||
(define decorated-editor-snip%
|
||||
(class (decorated-editor-snip-mixin editor-snip%)
|
||||
(inherit get-editor get-style)
|
||||
|
||||
;; make-snip : -> this%
|
||||
;; returns an instance of this class. used in the copy method
|
||||
(define/public (make-snip) (make-object decorated-editor-snip%))
|
||||
|
||||
;; make-editor : -> editor<%>
|
||||
;; returns the editor to be used in this snip.
|
||||
(define/public (make-editor) (make-object text%))
|
||||
|
||||
(define/override write
|
||||
(λ (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))
|
||||
|
||||
(super-new
|
||||
(editor (make-editor)))))
|
||||
|
||||
(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) (make-object decorated-editor-snip%))
|
||||
|
||||
(define/override (read stream-in)
|
||||
(let ([snip (make-snip stream-in)])
|
||||
(send (send snip get-editor) read-from-file stream-in #f)
|
||||
snip))
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,10 @@
|
|||
@title{@bold{Framework}: PLT GUI Application Framework}
|
||||
@(defmodule framework)
|
||||
|
||||
@itemize{@item{decorated editor snip isn't exported by framework/framework}}
|
||||
|
||||
----------------------------------------------------------------------------------------------------
|
||||
|
||||
The framework provides a number of mixins, classes and
|
||||
functions designed to help you build a complete application
|
||||
program on top of the @scheme[scheme/gui] library.
|
||||
|
|
@ -75,7 +79,13 @@ The precise set of exported names is:
|
|||
@scheme[preferences:set-default],
|
||||
@scheme[preferences:set-un/marshall], and
|
||||
@scheme[preferences:restore-defaults].
|
||||
}}
|
||||
}
|
||||
@item{@bold{Decorated Editor Snip}
|
||||
@scheme[(require framework/decorated-editor-snip)]
|
||||
|
||||
This library exports an editor snipclass
|
||||
}
|
||||
}
|
||||
|
||||
@bold{Thanks}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user