fixed a bunch of bugs in layout things in order to make traces/ps work better
svn: r13114
This commit is contained in:
Robby Findler
parent
e2751633f0
commit
d1f65ae6c9
|
|
@ -1,196 +1,171 @@
|
|||
(module size-snip mzscheme
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"matcher.ss")
|
||||
|
||||
(provide reflowing-snip<%>
|
||||
size-editor-snip%
|
||||
default-pretty-printer
|
||||
initial-char-width
|
||||
resizing-pasteboard-mixin)
|
||||
|
||||
(define initial-char-width (make-parameter 30))
|
||||
|
||||
(define (default-pretty-printer v port w spec)
|
||||
(parameterize ([pretty-print-columns w]
|
||||
[pretty-print-size-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val) 4]
|
||||
[(eq? val 'hole) 6]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val)
|
||||
(display "hole" op)]
|
||||
[(eq? val 'hole)
|
||||
(display ",'hole" op)]))])
|
||||
(pretty-print v port)))
|
||||
|
||||
(define reflowing-snip<%>
|
||||
(interface ()
|
||||
reflow-program))
|
||||
|
||||
(define (resizing-pasteboard-mixin pb%)
|
||||
(class pb%
|
||||
(init-field shrink-down?)
|
||||
|
||||
(define/augment (on-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) on-interactive-resize snip))
|
||||
|
||||
(define/augment (after-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) after-interactive-resize snip))
|
||||
|
||||
(define/override (interactive-adjust-resize snip w h)
|
||||
(super interactive-adjust-resize snip w h)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program)))
|
||||
|
||||
(inherit get-snip-location
|
||||
begin-edit-sequence
|
||||
end-edit-sequence)
|
||||
|
||||
(define/augment (on-insert snip before x y)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-insert snip before x y))
|
||||
(define/augment (after-insert snip before x y)
|
||||
(inner (void) after-insert snip before x y)
|
||||
(when (is-a? snip size-editor-snip%)
|
||||
(let ([cw (send snip get-char-width)]
|
||||
[woc (send snip get-width-of-char)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-snip-location snip #f bt #f)
|
||||
(get-snip-location snip #f bb #t)
|
||||
(send snip resize
|
||||
(* cw woc)
|
||||
(- (unbox bb) (unbox bt)))
|
||||
(when shrink-down?
|
||||
(send snip shrink-down))))
|
||||
(end-edit-sequence))
|
||||
(super-new)))
|
||||
|
||||
(define size-editor-snip%
|
||||
(class* editor-snip% (reflowing-snip<%>)
|
||||
(init-field expr)
|
||||
(init pp)
|
||||
(init-field char-width)
|
||||
(define real-pp
|
||||
(if (procedure-arity-includes? pp 4)
|
||||
pp
|
||||
(lambda (v port w spec) (display (pp v) port))))
|
||||
(inherit get-admin)
|
||||
(define/public (get-expr) expr)
|
||||
(define/public (get-char-width) char-width)
|
||||
|
||||
(define/override (resize w h)
|
||||
(super resize w h)
|
||||
(reflow-program))
|
||||
|
||||
(inherit get-editor)
|
||||
;; final
|
||||
(define/pubment (reflow-program)
|
||||
(let* ([tw (get-width-of-char)]
|
||||
[sw (get-snip-width)])
|
||||
(when (and tw sw)
|
||||
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
|
||||
(unless (equal? new-width char-width)
|
||||
(set! char-width new-width)
|
||||
(format-expr)
|
||||
(on-width-changed char-width))))))
|
||||
|
||||
;; final
|
||||
(define/pubment (shrink-down)
|
||||
(let ([ed (get-editor)]
|
||||
[bx (box 0)]
|
||||
[by (box 0)])
|
||||
(let ([max-line-width
|
||||
(let loop ([p 0]
|
||||
[max-w 0])
|
||||
(cond
|
||||
[(<= p (send ed last-paragraph))
|
||||
(send ed position-location
|
||||
(send ed paragraph-end-position p)
|
||||
bx by #t)
|
||||
(let ([this-w (unbox bx)])
|
||||
(loop (+ p 1)
|
||||
(max this-w max-w)))]
|
||||
[else max-w]))])
|
||||
(send ed position-location (send ed last-position) bx by #f)
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(super resize
|
||||
(+ max-line-width hms)
|
||||
(+ (unbox by) vms))))))
|
||||
|
||||
(inherit get-margin)
|
||||
(define/public (get-snip-width)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(let ([containing-editor (send admin get-editor)]
|
||||
[bl (box 0)]
|
||||
[br (box 0)])
|
||||
(send containing-editor get-snip-location this bl #f #f)
|
||||
(send containing-editor get-snip-location this br #f #t)
|
||||
(let ([outer-w (- (unbox br) (unbox bl))])
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(- outer-w hms)))))))
|
||||
|
||||
(define/private (get-margin-space)
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-margin bl bt br bb)
|
||||
(values (+ (unbox bl) (unbox br) 2) ;; not sure what the 2 is for. Maybe caret space?
|
||||
(+ (unbox bt) (unbox bb)))))
|
||||
|
||||
(define/public (get-width-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
tw))))))
|
||||
|
||||
(define/public (get-height-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
th))))))
|
||||
#lang scheme/base
|
||||
(require scheme/gui/base
|
||||
scheme/class
|
||||
framework
|
||||
scheme/pretty
|
||||
"matcher.ss")
|
||||
|
||||
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
|
||||
|
||||
(define/public (format-expr)
|
||||
(let* ([text (get-editor)]
|
||||
[port (open-output-text-editor text)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text thaw-colorer))
|
||||
(send text set-styles-sticky #f)
|
||||
(send text erase)
|
||||
(real-pp expr port char-width text)
|
||||
(unless (zero? (send text last-position))
|
||||
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
|
||||
(send text delete (- (send text last-position) 1) (send text last-position))))
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text freeze-colorer))
|
||||
(send text end-edit-sequence)))
|
||||
(provide reflowing-snip<%>
|
||||
size-editor-snip%
|
||||
size-text%
|
||||
default-pretty-printer
|
||||
initial-char-width
|
||||
resizing-pasteboard-mixin)
|
||||
|
||||
(define initial-char-width (make-parameter 30))
|
||||
|
||||
(define (default-pretty-printer v port w spec)
|
||||
(parameterize ([pretty-print-columns w]
|
||||
[pretty-print-size-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val) 4]
|
||||
[(eq? val 'hole) 6]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val)
|
||||
(display "hole" op)]
|
||||
[(eq? val 'hole)
|
||||
(display ",'hole" op)]))])
|
||||
(pretty-print v port)))
|
||||
|
||||
(define reflowing-snip<%>
|
||||
(interface ()
|
||||
reflow-program))
|
||||
|
||||
(define (resizing-pasteboard-mixin pb%)
|
||||
(class pb%
|
||||
|
||||
(define/augment (on-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) on-interactive-resize snip))
|
||||
|
||||
(define/augment (after-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) after-interactive-resize snip))
|
||||
|
||||
(define/override (interactive-adjust-resize snip w h)
|
||||
(super interactive-adjust-resize snip w h)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program)))
|
||||
|
||||
(inherit get-snip-location
|
||||
begin-edit-sequence
|
||||
end-edit-sequence
|
||||
find-first-snip
|
||||
get-dc)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define size-editor-snip%
|
||||
(class* editor-snip% (reflowing-snip<%>)
|
||||
(init-field expr)
|
||||
(init pp)
|
||||
(init-field char-width)
|
||||
(define real-pp
|
||||
(if (procedure-arity-includes? pp 4)
|
||||
pp
|
||||
(lambda (v port w spec) (display (pp v) port))))
|
||||
|
||||
(inherit get-admin)
|
||||
(define/public (get-expr) expr)
|
||||
(define/public (get-char-width) char-width)
|
||||
|
||||
(define/override (resize w h)
|
||||
(super resize w h)
|
||||
(reflow-program))
|
||||
|
||||
(inherit get-editor)
|
||||
;; final
|
||||
(define/pubment (reflow-program)
|
||||
(let* ([tw (get-width-of-char)]
|
||||
[sw (get-snip-width)])
|
||||
(when (and tw sw)
|
||||
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
|
||||
(unless (equal? new-width char-width)
|
||||
(set! char-width new-width)
|
||||
(format-expr)
|
||||
(on-width-changed char-width))))))
|
||||
|
||||
(inherit get-margin)
|
||||
(define/public (get-snip-width)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(let ([containing-editor (send admin get-editor)]
|
||||
[bl (box 0)]
|
||||
[br (box 0)])
|
||||
(send containing-editor get-snip-location this bl #f #f)
|
||||
(send containing-editor get-snip-location this br #f #t)
|
||||
(let ([outer-w (- (unbox br) (unbox bl))])
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(- outer-w hms)))))))
|
||||
|
||||
(define/private (get-margin-space)
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-margin bl bt br bb)
|
||||
(values (+ (unbox bl) (unbox br) 6) ;; not sure what the 2 is for. Maybe caret space?
|
||||
(+ (unbox bt) (unbox bb)))))
|
||||
|
||||
;; get-width-of-char : -> number or false
|
||||
;; depends on `dc' field
|
||||
(define/public (get-width-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
|
||||
[dc (send ed get-dc)])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
tw))))))
|
||||
|
||||
;; depends on `dc' field
|
||||
(define/public (get-height-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
th))))))
|
||||
|
||||
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
|
||||
|
||||
(define/public (format-expr)
|
||||
(let* ([text (get-editor)]
|
||||
[port (open-output-text-editor text)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text thaw-colorer))
|
||||
(send text set-styles-sticky #f)
|
||||
(send text erase)
|
||||
(real-pp expr port char-width text)
|
||||
(unless (zero? (send text last-position))
|
||||
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
|
||||
(send text delete (- (send text last-position) 1) (send text last-position))))
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text freeze-colorer))
|
||||
(send text end-edit-sequence)))
|
||||
|
||||
(super-new)
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t)))
|
||||
|
||||
(define size-text%
|
||||
(scheme:set-mode-mixin
|
||||
(scheme:text-mixin
|
||||
(color:text-mixin
|
||||
(text:autocomplete-mixin
|
||||
(mode:host-text-mixin
|
||||
(editor:standard-style-list-mixin
|
||||
text:basic%)))))))
|
||||
|
||||
(super-new)
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t))))
|
||||
|
|
|
|||
|
|
@ -77,7 +77,6 @@ todo:
|
|||
(define upper-hp (new horizontal-panel% [parent dp]))
|
||||
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
|
||||
(define pb (new columnar-pasteboard%
|
||||
[shrink-down? #f]
|
||||
[moved (λ (a b c d)
|
||||
(when (procedure? moved)
|
||||
(moved a b c d)))]))
|
||||
|
|
@ -801,7 +800,7 @@ todo:
|
|||
flat-to-remove)
|
||||
(for-each (λ (x) (insert x)) flat-to-insert)))
|
||||
|
||||
(inherit get-admin move-to resize)
|
||||
(inherit get-admin move-to)
|
||||
(define/public (update-heights)
|
||||
(let ([admin (get-admin)])
|
||||
(let-values ([(w h) (get-view-size)])
|
||||
|
|
@ -816,9 +815,11 @@ todo:
|
|||
;; if there is only a single snip in the column, we let it be as long as it wants to be.
|
||||
(let* ([snip (car column)]
|
||||
[sw (get-snip-width snip)]
|
||||
[sh (get-snip-max-height snip)])
|
||||
[sh (get-snip-max-height snip)]
|
||||
[new-height (- (max h sh) (get-border-height snip))])
|
||||
(move-to snip x 0)
|
||||
(resize snip sw (max h sh))
|
||||
(send snip set-min-height new-height)
|
||||
(send snip set-max-height new-height)
|
||||
(loop (cdr columns) (+ x sw)))]
|
||||
[else
|
||||
;; otherwise, we make all of the snips fit into the visible area
|
||||
|
|
@ -838,16 +839,39 @@ todo:
|
|||
0
|
||||
1))])
|
||||
(move-to snip x y)
|
||||
(resize snip sw h)
|
||||
(let ([border-height (get-border-height snip)])
|
||||
(send snip set-min-height (- h border-height))
|
||||
(send snip set-max-height (- h border-height)))
|
||||
(loop (cdr snips)
|
||||
(if (zero? extra-space)
|
||||
0
|
||||
(- extra-space 1))
|
||||
(+ y h)
|
||||
(max widest sw)))]))])
|
||||
(for-each (λ (snip)
|
||||
(let ([border-width (get-border-width snip)])
|
||||
(send snip set-min-width (- widest border-width))
|
||||
(send snip set-max-width (- widest border-width))))
|
||||
column)
|
||||
(loop (cdr columns)
|
||||
(+ x widest)))]))])))))
|
||||
|
||||
(define/private (get-border-height snip)
|
||||
(let ([lb (box 0)]
|
||||
[tb (box 0)]
|
||||
[rb (box 0)]
|
||||
[bb (box 0)])
|
||||
(send snip get-margin lb tb bb rb)
|
||||
(+ (unbox bb) (unbox tb))))
|
||||
|
||||
(define/private (get-border-width snip)
|
||||
(let ([lb (box 0)]
|
||||
[tb (box 0)]
|
||||
[rb (box 0)]
|
||||
[bb (box 0)])
|
||||
(send snip get-margin lb tb bb rb)
|
||||
(+ (unbox lb) (unbox rb))))
|
||||
|
||||
(inherit get-snip-location)
|
||||
(define/public (get-snip-width snip)
|
||||
(let ([lb (box 0)]
|
||||
|
|
|
|||
|
|
@ -1,15 +1,17 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; should cache the count of new snips -- dont
|
||||
;; use `count-snips'; use something associated with the
|
||||
;; equal hash-table
|
||||
|
||||
#lang scheme
|
||||
|
||||
(require mrlib/graph
|
||||
"reduction-semantics.ss"
|
||||
"matcher.ss"
|
||||
"size-snip.ss"
|
||||
"dot.ss"
|
||||
scheme/gui/base
|
||||
scheme/class
|
||||
scheme/file
|
||||
framework)
|
||||
|
||||
(preferences:set-default 'plt-reducer:show-bottom #t boolean?)
|
||||
|
|
@ -139,12 +141,83 @@
|
|||
#:scheme-colors? scheme-colors?
|
||||
#:colors colors
|
||||
#:layout layout)])
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file filename)
|
||||
(send ps-setup set-mode 'file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(send graph-pb print #f #f 'postscript #f #f #t)))))
|
||||
(print-to-ps graph-pb filename)))
|
||||
|
||||
(define (print-to-ps graph-pb filename)
|
||||
(let ([admin (send graph-pb get-admin)]
|
||||
[printing-admin (new printing-editor-admin%)])
|
||||
(send graph-pb set-admin printing-admin)
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(send snip size-cache-invalid)
|
||||
(loop (send snip next))))
|
||||
(send graph-pb invalidate-bitmap-cache)
|
||||
|
||||
(send graph-pb re-run-layout)
|
||||
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file filename)
|
||||
(send ps-setup set-mode 'file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(send graph-pb print #f #f 'postscript #f #f #t))))
|
||||
|
||||
(λ ()
|
||||
(send graph-pb set-admin admin)
|
||||
(send printing-admin shutdown) ;; do this early
|
||||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(send snip size-cache-invalid)
|
||||
(loop (send snip next))))
|
||||
(send graph-pb invalidate-bitmap-cache)
|
||||
(send graph-pb re-run-layout)))))
|
||||
|
||||
(define printing-editor-admin%
|
||||
(class editor-admin%
|
||||
|
||||
(define temp-file (make-temporary-file "redex-size-snip-~a"))
|
||||
|
||||
(define ps-dc
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file temp-file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(make-object post-script-dc% #f #f #f #t))))
|
||||
|
||||
(send ps-dc start-doc "fake dc")
|
||||
(send ps-dc start-page)
|
||||
(super-new)
|
||||
|
||||
(define/public (shutdown)
|
||||
(send ps-dc end-page)
|
||||
(send ps-dc end-doc)
|
||||
(delete-file temp-file))
|
||||
|
||||
|
||||
(define/override (get-dc [x #f] [y #f])
|
||||
(super get-dc x y)
|
||||
ps-dc)
|
||||
(define/override (get-max-view x y w h [full? #f])
|
||||
(get-view x y w h full?))
|
||||
(define/override (get-view x y w h [full? #f])
|
||||
(super get-view x y w h full?)
|
||||
(when (box? w) (set-box! w 500))
|
||||
(when (box? h) (set-box! h 500)))
|
||||
|
||||
;; the following methods are not overridden; they all default to doing nothing.
|
||||
;; grab-caret
|
||||
;; modified
|
||||
;; needs-update
|
||||
;; popup-menu
|
||||
;; refresh-delayed?
|
||||
;; resized
|
||||
;; scroll-to
|
||||
;; update-cursor
|
||||
))
|
||||
|
||||
(define (traces reductions pre-exprs
|
||||
#:multiple? [multiple? #f]
|
||||
|
|
@ -157,7 +230,7 @@
|
|||
(define exprs (if multiple? pre-exprs (list pre-exprs)))
|
||||
(define main-eventspace (current-eventspace))
|
||||
(define saved-parameterization (current-parameterization))
|
||||
(define graph-pb (new graph-pasteboard% [shrink-down? #t]))
|
||||
(define graph-pb (new graph-pasteboard% [layout layout]))
|
||||
(define f (instantiate red-sem-frame% ()
|
||||
(label "PLT Redex Reduction Graph")
|
||||
(style '(toolbar-button))
|
||||
|
|
@ -275,7 +348,7 @@
|
|||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip shrink-down))
|
||||
(send snip reflow-program))
|
||||
(loop (send snip next))))))
|
||||
|
||||
;; fill-out : (listof X) (listof X) -> (listof X)
|
||||
|
|
@ -338,7 +411,7 @@
|
|||
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
|
||||
(begin0
|
||||
(insert-into col y graph-pb new-snips)
|
||||
(layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
|
||||
(send graph-pb re-run-layout)
|
||||
(send graph-pb end-edit-sequence)
|
||||
(send status-message set-label
|
||||
(string-append (term-count (count-snips)) "...")))))])
|
||||
|
|
@ -469,7 +542,7 @@
|
|||
null)))
|
||||
(out-of-dot-state) ;; make sure the state is initialized right
|
||||
(insert-into init-rightmost-x 0 graph-pb frontier)
|
||||
(layout (map (lambda (y) (send y get-term-node)) frontier))
|
||||
(send graph-pb re-run-layout)
|
||||
(set-font-size (initial-font-size))
|
||||
(cond
|
||||
[no-show-frame?
|
||||
|
|
@ -507,6 +580,10 @@
|
|||
(define graph-pasteboard%
|
||||
(class (resizing-pasteboard-mixin
|
||||
(graph-pasteboard-mixin pasteboard%))
|
||||
|
||||
(init-field layout) ;; (-> (listof term-node) void)
|
||||
;; this is the function supplied by the :#layout argument to traces or traces/ps
|
||||
|
||||
(define dot-callback #f)
|
||||
(define/public (set-dot-callback cb) (set! dot-callback cb))
|
||||
(define/override (draw-edges dc left top right bottom dx dy)
|
||||
|
|
@ -521,6 +598,17 @@
|
|||
(define/augment (can-interactive-move? evt) mobile?)
|
||||
(define/augment (can-interactive-resize? evt) mobile?)
|
||||
|
||||
(inherit find-first-snip)
|
||||
(define/public (re-run-layout)
|
||||
(layout
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(cond
|
||||
[(not snip) '()]
|
||||
[(is-a? snip reflowing-snip<%>)
|
||||
(cons (send snip get-term-node)
|
||||
(loop (send snip next)))]
|
||||
[else (loop (send snip next))]))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define graph-editor-snip%
|
||||
|
|
@ -578,7 +666,7 @@
|
|||
(super-new)))
|
||||
|
||||
(define program-text%
|
||||
(class scheme:text%
|
||||
(class size-text%
|
||||
(define bad-color #f)
|
||||
(define/public (set-bad color) (set! bad-color color))
|
||||
|
||||
|
|
@ -688,6 +776,7 @@
|
|||
(pp pp)
|
||||
(expr expr))])
|
||||
(send text set-autowrap-bitmap #f)
|
||||
(send text set-max-width 'none)
|
||||
(send text freeze-colorer)
|
||||
(send text stop-colorer (not scheme-colors?))
|
||||
(send es format-expr)
|
||||
|
|
|
|||
|
|
@ -213,12 +213,13 @@ looking for a decomposition, it ignores any holes found in
|
|||
that @|pattern|.
|
||||
}
|
||||
|
||||
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches
|
||||
what the embedded @pattern matches, and then the guard expression is
|
||||
evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it
|
||||
returns anything else, the @pattern matches. In addition, any
|
||||
occurrences of `name' in the @pattern are bound using @scheme[term-let]
|
||||
in the guard.
|
||||
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
|
||||
matches what the embedded @pattern matches, and then the guard
|
||||
expression is evaluated. If it returns @scheme[#f], the @pattern fails
|
||||
to match, and if it returns anything else, the @pattern matches. Any
|
||||
occurrences of `name' in the @pattern (including those implicitly
|
||||
there via @tt{_} pattersn) are bound using @scheme[term-let] in the
|
||||
guard.
|
||||
}
|
||||
|
||||
@item{The @tt{(@defpattech[cross] symbol)} @pattern is used for the compatible
|
||||
|
|
@ -1367,9 +1368,18 @@ the stepper and traces.
|
|||
@defparam[dark-pen-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[dark-brush-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-pen-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}]]{
|
||||
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[dark-text-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-text-color color (or/c string? (is-a?/c color<%>))]{}]]{
|
||||
|
||||
These four parameters control the color of the edges in the graph.
|
||||
These six parameters control the color of the edges in the graph.
|
||||
|
||||
The dark colors are used when the mouse is over one of the nodes that
|
||||
is connected to this edge. The light colors are used when it isn't.
|
||||
|
||||
The pen colors control the color of the line. The brush colors control
|
||||
the color used to fill the arrowhead and the text colors control the
|
||||
color used to draw the label on the edge.
|
||||
}
|
||||
|
||||
@defproc[(default-pretty-printer [v any] [port output-port] [width number] [text (is-a?/c text%)]) void?]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user