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

Rackety

Browse Source 
original commit: 5522c72ecbd38147d80fb8c85539a6038b7ce527
This commit is contained in:
Robby Findler 2011-04-01 18:29:37 -05:00
parent 46d78f1897
commit 9a09899bc7
1 changed files with 42 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/mrlib/graph.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(module graph mzscheme (require racket/class
(require mzlib/class racket/list
mzlib/list racket/math
mzlib/math racket/gui/base
mred (for-syntax racket/base)
mzlib/contract) racket/contract)
(provide graph-snip<%> (provide graph-snip<%>
graph-snip-mixin graph-snip-mixin
@ -29,61 +29,61 @@
(define-local-member-name get-parent-links) (define-local-member-name get-parent-links)
(provide/contract (add-links (provide/contract (add-links
(case-> (case->
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
. -> . . -> .
void?) void?)
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
. -> . . -> .
void?) void?)
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c string?) (or/c #f string?)
. -> . . -> .
void?) void?)
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
number? number?
number? number?
. -> . . -> .
void?) void?)
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
number? number?
number? number?
(or/c false/c string?) (or/c #f string?)
. -> . . -> .
void?))) void?)))
(add-links/text-colors (add-links/text-colors
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c pen%)) (or/c #f (is-a?/c pen%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c brush%)) (or/c #f (is-a?/c brush%))
(or/c false/c (is-a?/c color%)) (or/c #f (is-a?/c color%))
(or/c false/c (is-a?/c color%)) (or/c #f (is-a?/c color%))
number? number?
number? number?
(or/c false/c string?) (or/c #f string?)
. -> . . -> .
void?)) void?))
(remove-links (remove-links
@ -94,7 +94,7 @@
(set-link-label (set-link-label
((is-a?/c graph-snip<%>) ((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>)
(or/c false/c string?) (or/c #f string?)
. -> . . -> .
void?))) void?)))
@ -126,7 +126,7 @@
;; label is boolean or string ;; label is boolean or string
(define-struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) (define-struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy [label #:mutable]))
;; add-links : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) -> void ;; add-links : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) -> void
;; : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) pen pen brush brush -> void ;; : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) pen pen brush brush -> void
@ -217,11 +217,11 @@
(memq this (get-children))) (memq this (get-children)))
(define/public (find-shortest-path other) (define/public (find-shortest-path other)
(define visited-ht (make-hash-table)) (define visited-ht (make-hasheq))
(define (first-view? n) (define (first-view? n)
(hash-table-get visited-ht n (lambda () (hash-ref visited-ht n (lambda ()
(hash-table-put! visited-ht n #f) (hash-set! visited-ht n #f)
#t))) #t)))
(let loop ((horizon (list (list this)))) (let loop ((horizon (list (list this))))
(cond (cond
[(null? horizon) #f] [(null? horizon) #f]
@ -524,7 +524,6 @@
(super on-paint before? dc left top right bottom dx dy draw-caret)) (super on-paint before? dc left top right bottom dx dy draw-caret))
(define/public (draw-edges dc left top right bottom dx dy) (define/public (draw-edges dc left top right bottom dx dy)
(let ()
;; draw-connection : link snip boolean boolean -> void ;; draw-connection : link snip boolean boolean -> void
;; sets the drawing context (pen and brush) ;; sets the drawing context (pen and brush)
;; determines if the connection is between a snip and itself or two different snips ;; determines if the connection is between a snip and itself or two different snips
@ -695,7 +694,7 @@
(send dc set-smoothing os) (send dc set-smoothing os)
(send dc set-pen old-pen) (send dc set-pen old-pen)
(send dc set-text-foreground old-fg) (send dc set-text-foreground old-fg)
(send dc set-brush old-brush)))) (send dc set-brush old-brush)))
(define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?) (define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
(send dc draw-line (send dc draw-line
@ -713,7 +712,6 @@
;; for-each-to-redraw : number number number number (link snip -> void) ;; for-each-to-redraw : number number number number (link snip -> void)
(define/private (for-each-to-redraw left top right bottom f) (define/private (for-each-to-redraw left top right bottom f)
(let ()
;; : link snip boolean boolean -> void ;; : link snip boolean boolean -> void
;; sets the drawing context (pen and brush) ;; sets the drawing context (pen and brush)
;; determines if the connection is between a snip and itself or two different snips ;; determines if the connection is between a snip and itself or two different snips
@ -750,7 +748,7 @@
(is-a? snip graph-snip<%>)) (is-a? snip graph-snip<%>))
(for-each (lambda (parent-link) (maybe-call-f parent-link snip)) (for-each (lambda (parent-link) (maybe-call-f parent-link snip))
(send snip get-parent-links))) (send snip get-parent-links)))
(loop (send snip next)))))) (loop (send snip next)))))
(field (field
@ -921,5 +919,5 @@
;; get-all-parents : snip -> (listof snip) ;; get-all-parents : snip -> (listof snip)
(define (get-all-parents snip) (define (get-all-parents snip)
(get-all-relatives (lambda (snip) (send snip get-parents)) snip))) (get-all-relatives (lambda (snip) (send snip get-parents)) snip))