├── LICENSE
├── README.md
├── bin
    ├── README.md
    ├── phlisp
    └── run
├── commands
    ├── README.md
    ├── add-child.rkt
    ├── add-sibling.rkt
    ├── argify.rkt
    ├── command-line.phl
    ├── delete-link.rkt
    ├── insert-text.rkt
    ├── interlocute-lambda.rkt
    ├── interlocute-parent.phl
    ├── movement.rkt
    ├── paste.rkt
    ├── reify.rkt
    ├── run-code.rkt
    ├── scope.rkt
    ├── search.rkt
    ├── undo-redo.rkt
    └── write-to-file.rkt
├── core
    ├── README.md
    ├── commands-common.rkt
    ├── common.rkt
    ├── compiler.rkt
    ├── disp.rkt
    ├── extractdata.rkt
    ├── find.rkt
    ├── gnode.rkt
    ├── graph.rkt
    ├── main.rkt
    └── phlisp.rkt
├── doc
    ├── phlisp.md
    └── spec
├── tests
    ├── skeleton.phl
    └── test-extractdata.rkt
└── visualizations
    ├── README.md
    ├── default-horizontal-v11n.rkt
    ├── default-vertical-v11n.rkt
    ├── disk.phl
    ├── helpers
        ├── def-painter.rkt
        ├── default-v11n.rkt
        ├── linear-vertical-v11n.rkt
        └── stdlib.rkt
    ├── hyperbolic-disk.phl
    ├── other-v11n.rkt
    ├── other2-v11n.phl_inactive
    ├── other2-v11n.rkt
    ├── treemap-v11n.phl_inactive
    └── treemap-v11n.rkt_inactive


/LICENSE:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2014 Philip Monk
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of
 6 | this software and associated documentation files (the "Software"), to deal in
 7 | the Software without restriction, including without limitation the rights to
 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
 9 | the Software, and to permit persons to whom the Software is furnished to do so,
10 | subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | phlisp
 2 | ======
 3 | 
 4 | phlisp is a language combined with the phlisped graphical editor.
 5 | 
 6 | To run, run `bin/run <filename>`.  To compile phlisp code, run `bin/phlisp <filename>`.  A good test is `visualizations/disk.phl`, but don't make any permanent changes to it unless you know what you're doing.  A skeleton file is in `tests/skeleton.phl`.
 7 | 
 8 | This is released completely as-is.  If you want help getting this to run, or if you want to understand the code, or the ideas behind it, go ahead and contact me.  You can leave a comment on my blog [0] or you can open an issue on GitHub.  This project is not under active development, but I'm still interested in graphical programming.
 9 | 
10 | [0] http://pcmonk.wordpress.com
11 | 
12 | 


--------------------------------------------------------------------------------
/bin/README.md:
--------------------------------------------------------------------------------
1 | Bin
2 | ===
3 | 
4 | This directory contains executables.  Currently, all executables assume a Unix environment.
5 | 
6 | 


--------------------------------------------------------------------------------
/bin/phlisp:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 | 
3 | racket core/phlisp.rkt $@
4 | 
5 | 


--------------------------------------------------------------------------------
/bin/run:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 | 
3 | racket core/main.rkt $@
4 | 
5 | 


--------------------------------------------------------------------------------
/commands/README.md:
--------------------------------------------------------------------------------
1 | Commands
2 | ========
3 | 
4 | All the available key commands are in this directory.  A key command can really do whatever it wants, with the only restriction being that it must provide the symbol 'data' as a list.  For each command, add the key(s) and function to the list, as in the following example: `(define data ('(#\/ enter-search) search '(search) handle-search))`
5 | 
6 | The api for accessing the screen and/or graph is currently undocumented.
7 | 
8 | 


--------------------------------------------------------------------------------
/commands/add-child.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/commands-common.rkt")
 5 | (require "../core/extractdata.rkt")
 6 | (require "../core/gnode.rkt")
 7 | 
 8 | (provide data add-child)
 9 | 
10 | (define add-child-ev
11 |  (event
12 |   (lambda (g id parent-id)
13 |    ((compose
14 |      (curryr graph-add-terminal-gnode Next-id)
15 |      (curryr graph-add-child-beg id Next-id))
16 |     g))
17 |   1
18 |   (lambda (tree id parent-id)
19 |    (set-union
20 |     (set (whole-tree-selection Selected-tree) (append (whole-tree-selection Selected-tree) (list 0)))
21 |     (list->set
22 |      (set-map
23 |       (whole-tree-open tree)
24 |       (curry adjust-laddr Next-id id
25 |              0
26 |              (whole-tree-utterance-tree tree))))))
27 |   (lambda ()
28 |    (semantic-go 'down Selected-tree))))
29 | 
30 | ;(define (add-child event)
31 | ; (let* ((id (selected-id Selected-tree)))
32 | ;  (updater
33 | ;   #:graph-changer     (lambda ()
34 | ;                        (let ((gn (hash-ref G id)))
35 | ;                         (set-G (hash-set G id (parent-gnode id (gnode-name gn) (cons Next-id (if (parent-gnode? gn) (parent-gnode-childs gn) '())) (if (parent-gnode? gn) (parent-gnode-vars gn) '()))))
36 | ;			 (set-G (hash-set G Next-id (terminal-gnode id '-)))
37 | ;                         (set-Next-id (+ 1 Next-id))))
38 | ;   #:open-updater      (lambda ()
39 | ;                        (for-all-trees
40 | ;                         (lambda (tree)
41 | ;                          (set-whole-tree-open! tree (set-union (whole-tree-open tree) (set (whole-tree-selection Selected-tree) (append (whole-tree-selection Selected-tree) (list 0))))))))
42 | ;   #:selection-updater (lambda ()
43 | ;                        (semantic-go 'down Selected-tree)))))
44 | 
45 | (define add-child (event-wrapper add-child-ev))
46 | 
47 | (define data
48 |  (list '(#\( add-child) add-child))
49 | 
50 | 


--------------------------------------------------------------------------------
/commands/add-sibling.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/commands-common.rkt")
 5 | (require "../core/extractdata.rkt")
 6 | (require "../core/gnode.rkt")
 7 | 
 8 | (provide data add-sibling)
 9 | 
10 | (define add-sibling-ev
11 |  (event
12 |   (lambda (g id parent-id)
13 |    ((compose
14 |      (curryr graph-add-terminal-gnode Next-id)
15 |      (curryr graph-add-child-after parent-id id Next-id))
16 |     g))
17 |   1
18 |   (lambda (tree id parent-id)
19 |    (set-union
20 |     (list->set
21 |      (set-map
22 |       (whole-tree-open tree)
23 |       (curry adjust-laddr id parent-id
24 |              (last (whole-tree-selection Selected-tree))
25 |              (whole-tree-utterance-tree tree))))
26 |     (set (append (drop-right (whole-tree-selection Selected-tree) 1) (list (+ 1 (last (whole-tree-selection Selected-tree))))))))
27 |   (lambda ()
28 |    (semantic-go 'right Selected-tree))))
29 | 
30 | ;(define (add-sibling event)
31 | ; (let* ((id (selected-id Selected-tree))
32 | ;        (parent-id (selected-parent-id Selected-tree)))
33 | ;  (updater
34 | ;   #:graph-changer     (lambda ()
35 | ;                        (let ((gn (hash-ref G id))
36 | ;			      (pgn (hash-ref G parent-id)))
37 | ;			 (set-G (hash-set G parent-id (parent-gnode parent-id (gnode-name pgn) (replace id (list id Next-id) (parent-gnode-childs pgn)) (parent-gnode-vars pgn))))
38 | ;			 (set-G (hash-set G Next-id (terminal-gnode Next-id '-)))
39 | ;                         (set-Next-id (+ 1 Next-id))))
40 | ;   #:open-updater      (lambda ()
41 | ;                        (for-all-trees
42 | ;                         (lambda (tree)
43 | ;                          (set-whole-tree-open! tree
44 | ;                                                (set-union
45 | ;                                                 (list->set
46 | ;                                                  (set-map
47 | ;                                                   (whole-tree-open tree)
48 | ;                                                   (curry adjust-laddr id parent-id
49 | ;                                                          (last (whole-tree-selection Selected-tree))
50 | ;                                                          (whole-tree-utterance-tree tree))))
51 | ;                                                 (set (append (drop-right (whole-tree-selection Selected-tree) 1) (list (+ 1 (last (whole-tree-selection Selected-tree)))))))))))
52 | ;   #:selection-updater (lambda () (semantic-go 'right Selected-tree)))))
53 | 
54 | (define add-sibling (event-wrapper add-sibling-ev))
55 | 
56 | (define data
57 |  (list '(#\space add-sibling) add-sibling))
58 | 
59 | 


--------------------------------------------------------------------------------
/commands/argify.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require (except-in "../core/extractdata.rkt" LINK1 LINK1PARENT LINK1ADDR))
 5 | (require "../core/gnode.rkt")
 6 | (require "../core/disp.rkt")
 7 | (require (only-in "add-sibling.rkt" add-sibling))
 8 | (require (only-in "add-child.rkt" add-child))
 9 | 
10 | (provide data)
11 | 
12 | (define LINK1 '())
13 | (define LINK1PARENT '())
14 | (define LINK1ADDR '())
15 | 
16 | (define (argify event)
17 |  (set! LINK1 (selected-id Selected-tree))
18 |  (set! LINK1PARENT (selected-parent-id Selected-tree))
19 |  (set! LINK1ADDR (whole-tree-selection Selected-tree))
20 |  (enter-argify-mode))
21 | 
22 | (define (handle-argify event)
23 |  (with
24 |   ((let ((c (send event get-key-code)))
25 |     (cond
26 |      ((member c '(#\h #\j #\k #\l))
27 |       ((hash-ref key-evs c) event))
28 |      ((eq? c #\return)
29 |       (make-arg))
30 |      ((eq? c 'escape)
31 |       (exit-argify-mode))
32 |      (#t '()))))
33 | 
34 |   (make-arg ()
35 |    (let* ((link2 (selected-id Selected-tree))
36 |           (parent-link2 (selected-parent-id Selected-tree))
37 |           (arg-id Next-id))
38 |     (updater
39 |      #:graph-changer     (lambda ()
40 |                           (let ((l2gn (hash-ref G link2))
41 | 				(pl2gn (hash-ref G parent-link2))
42 | 				(l1gn (hash-ref G LINK1)))
43 |                            (with
44 |                             ((set-Next-id (+ 1 Next-id))
45 |                              (add-arg-to-hijito)
46 |                              (convert-var-to-arg))
47 |                    
48 |                             (add-arg-to-hijito ()
49 | 			     (set-G (hash-set G LINK1 (function-gnode LINK1 (gnode-name l1gn) (variable-gnode-defined l1gn) (append (function-gnode-args l1gn) (list arg-id)))))
50 | 			     (set-G (hash-set G arg-id (argument-gnode arg-id 'arger))))
51 |                    
52 |                             (convert-var-to-arg ()
53 |                              (set-G ((if (variable-gnode? l2gn) swap-var swap-normal))))
54 |                    
55 |                             (swap-normal ()
56 |                              (hash-set G parent-link2 (parent-gnode parent-link2 (gnode-name pl2gn) (replace link2 (list arg-id) (parent-gnode-childs pl2gn)) (parent-gnode-vars pl2gn))))
57 |                    
58 |                             (swap-var ()
59 | 			     (hash-set G link2 (variable-gnode link2 (gnode-name l2gn) arg-id))))))
60 |      #:selection-updater (lambda ()
61 |                           (exit-argify-mode)))))))
62 | 
63 | (define data
64 |  (list
65 |   '(#\a enter-argify) argify
66 |   '(argify) handle-argify))
67 | 
68 | 


--------------------------------------------------------------------------------
/commands/command-line.phl:
--------------------------------------------------------------------------------
1 | #hash((0 . #s((parent-gnode gnode 2) 0 - (1 6 53 199 251 256 9) ())) (1 . #s((parent-gnode gnode 2) 1 - (2 3 4 5 106) ())) (2 . #s((terminal-gnode (1 #t) gnode 2) 2 require #t)) (3 . #s((terminal-gnode (1 #t) gnode 2) 3 |"../core/common.rkt"| #t)) (4 . #s((terminal-gnode (1 #t) gnode 2) 4 |"../core/commands-common.rkt"| #t)) (5 . #s((terminal-gnode (1 #t) gnode 2) 5 |"../core/extractdata.rkt"| #t)) (6 . #s((parent-gnode gnode 2) 6 - (7 8 205) ())) (7 . #s((terminal-gnode (1 #t) gnode 2) 7 provide #t)) (8 . #s((terminal-gnode (1 #t) gnode 2) 8 data #t)) (9 . #s((parent-gnode gnode 2) 9 - (10 11 12) ())) (10 . #s((terminal-gnode (1 #t) gnode 2) 10 define #t)) (next-id . 271) (11 . #s((terminal-gnode (1 #t) gnode 2) 11 data #t)) (12 . #s((parent-gnode gnode 2) 12 - (13 146 17 206 213 147 31) (213 22 17))) (13 . #s((terminal-gnode (1 #t) gnode 2) 13 list #t)) (14 . #s((terminal-gnode (1 #t) gnode 2) 14 |#\;| #t)) (15 . #s((parent-gnode gnode 2) 15 - (218 220 224) (28))) (17 . #s((function-gnode variable-gnode 1 gnode 2) 17 command-line 15 (29))) (18 . #s((parent-gnode gnode 2) 18 - (20) ())) (19 . #s((terminal-gnode (1 #t) gnode 2) 19 quote #t)) (20 . #s((terminal-gnode (1 #t) gnode 2) 20 command #t)) (21 . #s((parent-gnode gnode 2) 21 - (30) ())) (22 . #s((function-gnode variable-gnode 1 gnode 2) 22 handle-command 21 ())) (23 . #s((terminal-gnode (1 #t) gnode 2) 23 push-mode #t)) (24 . #s((parent-gnode gnode 2) 24 - (25 26) ())) (25 . #s((terminal-gnode (1 #t) gnode 2) 25 quote #t)) (26 . #s((terminal-gnode (1 #t) gnode 2) 26 command #t)) (27 . #s((terminal-gnode (1 #t) gnode 2) 27 - #t)) (28 . #s((variable-gnode gnode 2) 28 event 29)) (29 . #s((argument-gnode (1 #t) gnode 2) 29 arger #t)) (30 . #s((terminal-gnode (1 #t) gnode 2) 30 - #t)) (31 . #s((parent-gnode gnode 2) 31 - (32 33 35) (35))) (32 . #s((terminal-gnode (1 #t) gnode 2) 32 curry #t)) (33 . #s((terminal-gnode (1 #t) gnode 2) 33 distributor #t)) (34 . #s((parent-gnode gnode 2) 34 - (36 37 167 42 45 56 58 49 85) (167 85 76))) (35 . #s((variable-gnode gnode 2) 35 h 34)) (36 . #s((terminal-gnode (1 #t) gnode 2) 36 hash #t)) (37 . #s((terminal-gnode (1 #t) gnode 2) 37 |#\return| #t)) (38 . #s((parent-gnode gnode 2) 38 - (39) ())) (39 . #s((terminal-gnode (1 #t) gnode 2) 39 thunk* #t)) (40 . #s((parent-gnode gnode 2) 40 - (41) ())) (41 . #s((terminal-gnode (1 #t) gnode 2) 41 pop-mode #t)) (42 . #s((parent-gnode gnode 2) 42 - (43 44) ())) (43 . #s((terminal-gnode (1 #t) gnode 2) 43 quote #t)) (44 . #s((terminal-gnode (1 #t) gnode 2) 44 escape #t)) (45 . #s((parent-gnode gnode 2) 45 - (46 47) ())) (46 . #s((terminal-gnode (1 #t) gnode 2) 46 thunk* #t)) (47 . #s((parent-gnode gnode 2) 47 - (48) ())) (48 . #s((terminal-gnode (1 #t) gnode 2) 48 pop-mode #t)) (49 . #s((parent-gnode gnode 2) 49 - (50 51) ())) (50 . #s((terminal-gnode (1 #t) gnode 2) 50 quote #t)) (51 . #s((terminal-gnode (1 #t) gnode 2) 51 else #t)) (52 . #s((parent-gnode gnode 2) 52 - (87 107 127) (98 113))) (53 . #s((parent-gnode gnode 2) 53 - (54 55 105) ())) (54 . #s((terminal-gnode (1 #t) gnode 2) 54 define #t)) (55 . #s((terminal-gnode (1 #t) gnode 2) 55 Command-line #t)) (56 . #s((terminal-gnode (1 #t) gnode 2) 56 |#\backspace| #t)) (58 . #s((parent-gnode gnode 2) 58 - (60 138 129) ())) (60 . #s((terminal-gnode (1 #t) gnode 2) 60 thunk* #t)) (61 . #s((parent-gnode gnode 2) 61 - (62 63 64) ())) (62 . #s((terminal-gnode (1 #t) gnode 2) 62 set! #t)) (63 . #s((terminal-gnode (1 #t) gnode 2) 63 Command-line #t)) (65 . #s((terminal-gnode (1 #t) gnode 2) 65 substring #t)) (64 . #s((parent-gnode gnode 2) 64 - (65 66 67 68) ())) (67 . #s((terminal-gnode (1 #t) gnode 2) 67 0 #t)) (66 . #s((terminal-gnode (1 #t) gnode 2) 66 Command-line #t)) (69 . #s((terminal-gnode (1 #t) gnode 2) 69 - #t)) (68 . #s((parent-gnode gnode 2) 68 - (69 70 74) ())) (71 . #s((terminal-gnode (1 #t) gnode 2) 71 string-length #t)) (70 . #s((parent-gnode gnode 2) 70 - (71 72) ())) (73 . #s((terminal-gnode (1 #t) gnode 2) 73 - #t)) (72 . #s((terminal-gnode (1 #t) gnode 2) 72 Command-line #t)) (75 . #s((parent-gnode gnode 2) 75 - (122 124 80) ())) (74 . #s((terminal-gnode (1 #t) gnode 2) 74 1 #t)) (77 . #s((terminal-gnode (1 #t) gnode 2) 77 set-info #t)) (76 . #s((function-gnode variable-gnode 1 gnode 2) 76 show-command-line 75 ())) (78 . #s((terminal-gnode (1 #t) gnode 2) 78 Command-line #t)) (81 . #s((terminal-gnode (1 #t) gnode 2) 81 send #t)) (80 . #s((parent-gnode gnode 2) 80 - (81 82 83) ())) (83 . #s((terminal-gnode (1 #t) gnode 2) 83 on-paint #t)) (82 . #s((terminal-gnode (1 #t) gnode 2) 82 Thecanvas #t)) (85 . #s((function-gnode variable-gnode 1 gnode 2) 85 - 52 (99))) (87 . #s((terminal-gnode (1 #t) gnode 2) 87 begin #t)) (86 . #s((terminal-gnode (1 #t) gnode 2) 86 set! #t)) (89 . #s((terminal-gnode (1 #t) gnode 2) 89 string-append #t)) (88 . #s((parent-gnode gnode 2) 88 - (89 90 91) ())) (91 . #s((parent-gnode gnode 2) 91 - (92 113) ())) (90 . #s((terminal-gnode (1 #t) gnode 2) 90 Command-line #t)) (93 . #s((parent-gnode gnode 2) 93 - (94 98 96) ())) (92 . #s((terminal-gnode (1 #t) gnode 2) 92 string #t)) (95 . #s((terminal-gnode (1 #t) gnode 2) 95 event #t)) (94 . #s((terminal-gnode (1 #t) gnode 2) 94 send #t)) (97 . #s((terminal-gnode (1 #t) gnode 2) 97 - #t)) (96 . #s((terminal-gnode (1 #t) gnode 2) 96 get-key-code #t)) (99 . #s((argument-gnode (1 #t) gnode 2) 99 arger #t)) (98 . #s((variable-gnode gnode 2) 98 event 99)) (101 . #s((terminal-gnode (1 #t) gnode 2) 101 - #t)) (100 . #s((parent-gnode gnode 2) 100 - (102 103 88) ())) (103 . #s((terminal-gnode (1 #t) gnode 2) 103 Command-line #t)) (102 . #s((terminal-gnode (1 #t) gnode 2) 102 set! #t)) (105 . #s((terminal-gnode (1 #t) gnode 2) 105 |""| #t)) (104 . #s((terminal-gnode (1 #t) gnode 2) 104 - #t)) (107 . #s((parent-gnode gnode 2) 107 - (108 109 100) ())) (106 . #s((terminal-gnode (1 #t) gnode 2) 106 |"../core/disp.rkt"| #t)) (109 . #s((parent-gnode gnode 2) 109 - (110 113) ())) (108 . #s((terminal-gnode (1 #t) gnode 2) 108 when #t)) (111 . #s((parent-gnode gnode 2) 111 - (118 98 120) ())) (110 . #s((terminal-gnode (1 #t) gnode 2) 110 char? #t)) (113 . #s((variable-gnode gnode 2) 113 c 111)) (112 . #s((terminal-gnode (1 #t) gnode 2) 112 - #t)) (119 . #s((terminal-gnode (1 #t) gnode 2) 119 - #t)) (118 . #s((terminal-gnode (1 #t) gnode 2) 118 send #t)) (121 . #s((terminal-gnode (1 #t) gnode 2) 121 - #t)) (120 . #s((terminal-gnode (1 #t) gnode 2) 120 get-key-code #t)) (122 . #s((terminal-gnode (1 #t) gnode 2) 122 begin #t)) (125 . #s((terminal-gnode (1 #t) gnode 2) 125 set-info #t)) (124 . #s((parent-gnode gnode 2) 124 - (125 126) ())) (127 . #s((parent-gnode gnode 2) 127 - (76) ())) (126 . #s((terminal-gnode (1 #t) gnode 2) 126 Command-line #t)) (130 . #s((terminal-gnode (1 #t) gnode 2) 130 - #t)) (131 . #s((parent-gnode gnode 2) 131 - (132 134) ())) (128 . #s((terminal-gnode (1 #t) gnode 2) 128 - #t)) (129 . #s((parent-gnode gnode 2) 129 - (76) ())) (134 . #s((terminal-gnode (1 #t) gnode 2) 134 |"wu?"| #t)) (135 . #s((parent-gnode gnode 2) 135 - (136 137) ())) (132 . #s((terminal-gnode (1 #t) gnode 2) 132 displayln #t)) (138 . #s((parent-gnode gnode 2) 138 - (139 143 61) ())) (139 . #s((terminal-gnode (1 #t) gnode 2) 139 when #t)) (136 . #s((terminal-gnode (1 #t) gnode 2) 136 displayln #t)) (137 . #s((terminal-gnode (1 #t) gnode 2) 137 |"wuu?"| #t)) (142 . #s((terminal-gnode (1 #t) gnode 2) 142 Command-line #t)) (143 . #s((parent-gnode gnode 2) 143 - (144 140 145) ())) (140 . #s((parent-gnode gnode 2) 140 - (141 142) ())) (141 . #s((terminal-gnode (1 #t) gnode 2) 141 string-length #t)) (146 . #s((parent-gnode gnode 2) 146 - (149 150) ())) (147 . #s((parent-gnode gnode 2) 147 - (148 18) ())) (144 . #s((terminal-gnode (1 #t) gnode 2) 144 > #t)) (145 . #s((terminal-gnode (1 #t) gnode 2) 145 0 #t)) (150 . #s((parent-gnode gnode 2) 150 - (14) ())) (151 . #s((parent-gnode gnode 2) 151 - (160) ())) (148 . #s((terminal-gnode (1 #t) gnode 2) 148 quote #t)) (149 . #s((terminal-gnode (1 #t) gnode 2) 149 quote #t)) (154 . #s((terminal-gnode (1 #t) gnode 2) 154 hash-has-key? #t)) (155 . #s((terminal-gnode (1 #t) gnode 2) 155 key-evs #t)) (152 . #s((terminal-gnode (1 #t) gnode 2) 152 if #t)) (153 . #s((parent-gnode gnode 2) 153 - (154 155 157) ())) (158 . #s((terminal-gnode (1 #t) gnode 2) 158 string->symbol #t)) (159 . #s((terminal-gnode (1 #t) gnode 2) 159 Command-line #t)) (156 . #s((parent-gnode gnode 2) 156 - (158 190) ())) (157 . #s((variable-gnode gnode 2) 157 sym 156)) (162 . #s((terminal-gnode (1 #t) gnode 2) 162 hash-ref #t)) (163 . #s((terminal-gnode (1 #t) gnode 2) 163 key-evs #t)) (160 . #s((parent-gnode gnode 2) 160 - (170) ())) (161 . #s((parent-gnode gnode 2) 161 - (162 163 157) ())) (166 . #s((parent-gnode gnode 2) 166 - (168 40 193) (170))) (167 . #s((function-gnode variable-gnode 1 gnode 2) 167 - 166 (171))) (164 . #s((terminal-gnode (1 #t) gnode 2) 164 - #t)) (165 . #s((terminal-gnode (1 #t) gnode 2) 165 null #t)) (170 . #s((variable-gnode gnode 2) 170 event 171)) (171 . #s((argument-gnode (1 #t) gnode 2) 171 arger #t)) (168 . #s((terminal-gnode (1 #t) gnode 2) 168 begin #t)) (169 . #s((terminal-gnode (1 #t) gnode 2) 169 - #t)) (174 . #s((terminal-gnode (1 #t) gnode 2) 174 process-command #t)) (175 . #s((parent-gnode gnode 2) 175 - (152 229 249 238) (190 157 157))) (172 . #s((parent-gnode gnode 2) 172 - (173 174) (177))) (173 . #s((terminal-gnode (1 #t) gnode 2) 173 define #t)) (177 . #s((function-gnode variable-gnode 1 gnode 2) 177 - 175 (191 192))) (186 . #s((parent-gnode gnode 2) 186 - (161 188) (188))) (187 . #s((terminal-gnode (1 #t) gnode 2) 187 - #t)) (190 . #s((variable-gnode gnode 2) 190 com 191)) (191 . #s((argument-gnode (1 #t) gnode 2) 191 arger #t)) (188 . #s((variable-gnode gnode 2) 188 event 192)) (195 . #s((terminal-gnode (1 #t) gnode 2) 195 Command-line #t)) (194 . #s((terminal-gnode (1 #t) gnode 2) 194 process-command #t)) (193 . #s((parent-gnode gnode 2) 193 - (194 195 170) ())) (192 . #s((argument-gnode (1 #t) gnode 2) 192 arger #t)) (199 . #s((parent-gnode gnode 2) 199 - (203 204 197) ())) (198 . #s((terminal-gnode (1 #t) gnode 2) 198 identity #t)) (197 . #s((parent-gnode gnode 2) 197 - (198 177) (177 177))) (196 . #s((terminal-gnode (1 #t) gnode 2) 196 - #t)) (203 . #s((terminal-gnode (1 #t) gnode 2) 203 define #t)) (207 . #s((terminal-gnode (1 #t) gnode 2) 207 quote #t)) (206 . #s((parent-gnode gnode 2) 206 - (207 208) ())) (205 . #s((terminal-gnode (1 #t) gnode 2) 205 process-command #t)) (204 . #s((terminal-gnode (1 #t) gnode 2) 204 process-command #t)) (209 . #s((terminal-gnode (1 #t) gnode 2) 209 |#\:| #t)) (208 . #s((parent-gnode gnode 2) 208 - (209) ())) (215 . #s((parent-gnode gnode 2) 215 - (216 217) ())) (214 . #s((terminal-gnode (1 #t) gnode 2) 214 push-mode #t)) (213 . #s((function-gnode variable-gnode 1 gnode 2) 213 continue-command-line 212 (227))) (212 . #s((parent-gnode gnode 2) 212 - (214 215) (226 226))) (218 . #s((terminal-gnode (1 #t) gnode 2) 218 begin #t)) (217 . #s((terminal-gnode (1 #t) gnode 2) 217 command #t)) (216 . #s((terminal-gnode (1 #t) gnode 2) 216 quote #t)) (223 . #s((terminal-gnode (1 #t) gnode 2) 223 |""| #t)) (222 . #s((terminal-gnode (1 #t) gnode 2) 222 Command-line #t)) (221 . #s((terminal-gnode (1 #t) gnode 2) 221 set! #t)) (220 . #s((parent-gnode gnode 2) 220 - (221 222 223) ())) (227 . #s((argument-gnode (1 #t) gnode 2) 227 arger #t)) (226 . #s((variable-gnode gnode 2) 226 event 227)) (225 . #s((terminal-gnode (1 #t) gnode 2) 225 - #t)) (224 . #s((parent-gnode gnode 2) 224 - (23 24) ())) (231 . #s((parent-gnode gnode 2) 231 - (232 190 234) ())) (230 . #s((terminal-gnode (1 #t) gnode 2) 230 eq? #t)) (229 . #s((parent-gnode gnode 2) 229 - (230 231 235) ())) (228 . #s((terminal-gnode (1 #t) gnode 2) 228 when #t)) (235 . #s((terminal-gnode (1 #t) gnode 2) 235 |#\(| #t)) (234 . #s((terminal-gnode (1 #t) gnode 2) 234 0 #t)) (233 . #s((terminal-gnode (1 #t) gnode 2) 233 - #t)) (232 . #s((terminal-gnode (1 #t) gnode 2) 232 string-ref #t)) (239 . #s((terminal-gnode (1 #t) gnode 2) 239 displayln #t)) (238 . #s((parent-gnode gnode 2) 238 - (228 153 186) ())) (237 . #s((parent-gnode gnode 2) 237 - (239 241) ())) (243 . #s((terminal-gnode (1 #t) gnode 2) 243 eval #t)) (242 . #s((parent-gnode gnode 2) 242 - (243 244 248) ())) (241 . #s((terminal-gnode (1 #t) gnode 2) 241 |"yoyoucrazyman"| #t)) (240 . #s((terminal-gnode (1 #t) gnode 2) 240 |"yo| #t)) (247 . #s((terminal-gnode (1 #t) gnode 2) 247 read #t)) (246 . #s((terminal-gnode (1 #t) gnode 2) 246 - #t)) (245 . #s((terminal-gnode (1 #t) gnode 2) 245 call-with-input-string #t)) (244 . #s((parent-gnode gnode 2) 244 - (245 190 247) ())) (251 . #s((parent-gnode gnode 2) 251 - (252 255) ())) (250 . #s((terminal-gnode (1 #t) gnode 2) 250 begin #t)) (249 . #s((parent-gnode gnode 2) 249 - (250 242) ())) (248 . #s((terminal-gnode (1 #t) gnode 2) 248 ns #t)) (255 . #s((terminal-gnode (1 #t) gnode 2) 255 a #t)) (254 . #s((terminal-gnode (1 #t) gnode 2) 254 - #t)) (253 . #s((parent-gnode gnode 2) 253 - (254) ())) (252 . #s((terminal-gnode (1 #t) gnode 2) 252 define-namespace-anchor #t)) (260 . #s((terminal-gnode (1 #t) gnode 2) 260 - #t)) (261 . #s((terminal-gnode (1 #t) gnode 2) 261 ns #t)) (262 . #s((parent-gnode gnode 2) 262 - (263 264) ())) (263 . #s((terminal-gnode (1 #t) gnode 2) 263 namespace-anchor->namespace #t)) (256 . #s((parent-gnode gnode 2) 256 - (257 261 268) ())) (257 . #s((terminal-gnode (1 #t) gnode 2) 257 define #t)) (258 . #s((parent-gnode gnode 2) 258 - (259) ())) (259 . #s((terminal-gnode (1 #t) gnode 2) 259 ns #t)) (268 . #s((parent-gnode gnode 2) 268 - (269 270) ())) (269 . #s((terminal-gnode (1 #t) gnode 2) 269 namespace-anchor->namespace #t)) (270 . #s((terminal-gnode (1 #t) gnode 2) 270 a #t)) (264 . #s((terminal-gnode (1 #t) gnode 2) 264 a #t)) (265 . #s((parent-gnode gnode 2) 265 - (266 267) ())) (266 . #s((terminal-gnode (1 #t) gnode 2) 266 module->namespace #t)) (267 . #s((terminal-gnode (1 #t) gnode 2) 267 |"core/extractdata.rkt"| #t)))


--------------------------------------------------------------------------------
/commands/delete-link.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | 
 7 | (provide data delete-link)
 8 | 
 9 | (define (delete-link event)
10 |  (let* ((id (selected-id Selected-tree))
11 |         (parent-id (selected-parent-id Selected-tree)))
12 |   (with
13 |    ((if (not (member id (parent-gnode-childs (hash-ref G parent-id))))
14 |      '()
15 |      (updater
16 |       #:graph-changer (lambda ()
17 |                        (let ((pgn (hash-ref G parent-id)))
18 |                         (push-clipboard id)
19 | 			(if (> (length (parent-gnode-childs pgn)) 1)
20 | 			 (set-G (hash-set G parent-id (parent-gnode parent-id (gnode-name pgn) (remove id (parent-gnode-childs pgn)) (parent-gnode-vars pgn))))
21 | 			 (set-G (hash-set G parent-id (terminal-gnode parent-id (gnode-name pgn)))))))
22 |       #:open-updater  (lambda ()
23 |                        (update-open)
24 |                        (update-selection)))))
25 | 
26 |    (update-selection ()
27 |     (let ((laddr (whole-tree-selection Selected-tree)))
28 |      (with
29 |       ((if (find-utterance-from-laddr-safe (whole-tree-utterance-tree Selected-tree) (append (drop-right laddr 1) (list (+ 1 (last laddr)))))
30 |         (select-next-child)
31 |         (if (zero? (last laddr))
32 |          (select-parent)
33 |          (select-previous-child))))
34 | 
35 |       (select-next-child ()
36 |        '())
37 | 
38 |       (select-parent ()
39 |        (set-whole-tree-selection! Selected-tree (adjust-laddr-del id (last laddr) (whole-tree-utterance-tree Selected-tree) (drop-right laddr 1))))
40 | 
41 |       (select-previous-child ()
42 |        (set-whole-tree-selection! Selected-tree (adjust-laddr-del id (last laddr) (whole-tree-utterance-tree Selected-tree) (append (drop-right laddr 1) (list (+ -1 (last laddr))))))))))
43 | 
44 |    (update-open ()
45 |     (for-all-trees
46 |      (lambda (tree)
47 |       (with
48 |        ((set-whole-tree-open! tree (list->set (set-map (remove-deleted-laddrs) (adjust-laddrs)))))
49 | 
50 |        (remove-deleted-laddrs ()
51 |         (set-subtract
52 |          (whole-tree-open tree)
53 |           (set-remove (list->set (set-map (whole-tree-open tree) (curry remove-laddr-del-aux id (last (whole-tree-selection Selected-tree)) (whole-tree-utterance-tree tree)))) '())))
54 |  
55 |        (adjust-laddrs ()
56 |         (curry adjust-laddr-del id (last (whole-tree-selection Selected-tree)) (whole-tree-utterance-tree tree))))))))))
57 | 
58 | (define data
59 |  (list '(#\d delete-link) delete-link))
60 | 
61 | 


--------------------------------------------------------------------------------
/commands/insert-text.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "../core/common.rkt")
  4 | (require "../core/commands-common.rkt")
  5 | (require (except-in "../core/extractdata.rkt" LINK1 LINK1PARENT LINK1ADDR INSERTTEXT))
  6 | (require "../core/gnode.rkt")
  7 | (require "../core/disp.rkt")
  8 | (require (only-in "add-sibling.rkt" add-sibling))
  9 | (require (only-in "add-child.rkt" add-child))
 10 | (require (only-in "search.rkt" search-bound-variables))
 11 | 
 12 | (provide data)
 13 | 
 14 | (define INSERTTEXT "")
 15 | (define LINK1 '())
 16 | (define LINK1PARENT '())
 17 | (define LINK1ADDR '())
 18 | 
 19 | (define (insert-text event)
 20 |  (set! INSERTTEXT "")
 21 |  (enter-insert-mode))
 22 | 
 23 | (define (handle-insert event)
 24 |  (with
 25 |   ((let ((c (send event get-key-code)))
 26 |     (cond
 27 |      ((and (eq? c #\n) (send event get-control-down))
 28 |       (scroll-search-results)
 29 |       (show-search-tree get-rep)
 30 |       (send Thecanvas on-paint))
 31 |      ((and (char? c) (not (char-whitespace? c)) (not (char-iso-control? c)) (not (member c '(#\( #\) #\[ #\] #\{ #\} #\, #\' #\` #\|))))
 32 |       (set! INSERTTEXT (string-append INSERTTEXT (string (send event get-key-code))))
 33 |       (show-results))
 34 |      ((eq? c #\backspace)
 35 |       (set! INSERTTEXT (substring INSERTTEXT 0 (- (string-length INSERTTEXT) 1)))
 36 |       (show-results))
 37 |      ((eq? c #\space)
 38 |       (remove-search-tree)
 39 |       (if (and (send event get-shift-down) (not (null? Search-results)))
 40 |        (link-to (selected-id Selected-tree) (selected-parent-id Selected-tree) (caar Search-results))
 41 |        (write-text-to-graph))
 42 |       (exit-insert-mode)
 43 |       (add-sibling event)
 44 |       (insert-text event))
 45 |      ((eq? c #\()
 46 |       (remove-search-tree)
 47 |       (write-text-to-graph)
 48 |       (exit-insert-mode)
 49 |       (add-child event)
 50 |       (insert-text event))
 51 |      ((eq? c #\))
 52 |       (remove-search-tree)
 53 |       (write-text-to-graph)
 54 |       (exit-insert-mode)
 55 |       (semantic-go 'up Selected-tree)
 56 |       (insert-text event))
 57 |      ((eq? c #\return)
 58 |       (remove-search-tree)
 59 |       (if (and (send event get-shift-down) (not (null? Search-results)))
 60 |        (link-to (selected-id Selected-tree) (selected-parent-id Selected-tree) (caar Search-results))
 61 |        (write-text-to-graph))
 62 |       (exit-insert-mode))
 63 |      ((eq? c 'escape)
 64 |       (remove-search-tree)
 65 |       (send Thecanvas on-paint)
 66 |       (exit-insert-mode))
 67 |      (#t '()))))
 68 | 
 69 |   (show-results ()
 70 |    (set-search-results (search-bound-variables (node-data (utterance-node (whole-tree-selection-u Selected-tree))) INSERTTEXT))
 71 |    (show-search-tree get-rep)
 72 |    (set-info INSERTTEXT)
 73 |    (send Thecanvas on-paint))))
 74 | 
 75 | (define (link-to id1 parent-id1 id2)
 76 |  (let* ((gn2 (hash-ref G id2))
 77 |         (pgn1 (hash-ref G parent-id1)))
 78 |   (updater
 79 |    #:graph-changer (lambda ()
 80 |                     (cond
 81 |                      ((variable-gnode? gn2)
 82 |                       (set-G (hash-set G parent-id1
 83 |                               (cond
 84 |                                ((parent-gnode? pgn1) (parent-gnode parent-id1 (gnode-name pgn1) (replace id1 (list id2) (parent-gnode-childs pgn1)) (parent-gnode-vars pgn1)))
 85 |                                ((function-gnode? pgn1) (function-gnode parent-id1 (gnode-name pgn1) id2 (function-gnode-args pgn1)))
 86 |                                ((variable-gnode? pgn1) (variable-gnode parent-id1 (gnode-name pgn1) id2))
 87 |                                (#t '())))))
 88 |                      (#t '()))))))
 89 | 
 90 | (define (write-text-to-graph)
 91 |  (let* ((id (selected-id Selected-tree))
 92 |         (gn (hash-ref G id)))
 93 |   (updater
 94 |    #:graph-changer (lambda ()
 95 |                     (with
 96 |                      ((set-G
 97 |                        (hash-set G id
 98 |                         (cond
 99 |                          ((parent-gnode? gn) (parent-gnode (gnode-id gn) (get-insert-text) (parent-gnode-childs gn) (parent-gnode-vars gn)))
100 |                          ((function-gnode? gn) (function-gnode (gnode-id gn) (get-insert-text) (variable-gnode-defined gn) (function-gnode-args gn)))
101 |                          ((variable-gnode? gn) (variable-gnode (gnode-id gn) (get-insert-text) (variable-gnode-defined gn)))
102 |                          ((argument-gnode? gn) (argument-gnode (gnode-id gn) (get-insert-text)))
103 |                          ((terminal-gnode? gn) (terminal-gnode (gnode-id gn) (get-insert-text)))
104 |                          (#t '())))))
105 | 
106 |                      (get-insert-text ()
107 |                       (if (char-numeric? (car (string->list (if (eq? "" INSERTTEXT) "-" INSERTTEXT)))) (string->number INSERTTEXT) (string->symbol (if (eq? "" INSERTTEXT) "-" INSERTTEXT)))))))))
108 | 
109 | (define data
110 |  (list
111 |   '(#\i enter-insert) insert-text
112 |   '(insert) handle-insert))
113 | 
114 | 


--------------------------------------------------------------------------------
/commands/interlocute-lambda.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | 
 7 | (provide data)
 8 | 
 9 | (define (interlocute-lambda function? event)
10 |  (let* ((id (selected-id Selected-tree))
11 |         (parent-id (selected-parent-id Selected-tree))
12 | 	(pgn (hash-ref G parent-id)))
13 |   (updater
14 |    #:graph-changer (lambda ()
15 |                     (set-G (hash-set G parent-id (parent-gnode parent-id (gnode-name pgn) (replace id (list Next-id) (parent-gnode-childs pgn)) (cons Next-id (parent-gnode-vars pgn)))))
16 |                     (set-G (hash-set G Next-id (if function?
17 | 						(function-gnode Next-id (gnode-name pgn) id '())
18 | 						(variable-gnode Next-id (gnode-name pgn) id))))
19 |                     (set-Next-id (+ 1 Next-id)))
20 |    #:open-updater  (lambda ()
21 |                     (for-all-trees
22 |                      (lambda (tree)
23 |                       (set-whole-tree-open! tree (adjust-laddr-interlocute id (last (whole-tree-selection Selected-tree)) tree))))))))
24 | 
25 | (define data
26 |  (list 
27 |   '(#\v make-variable) (curry interlocute-lambda #f)
28 |   '(#\L make-lambda) (curry interlocute-lambda #t)))
29 | 


--------------------------------------------------------------------------------
/commands/interlocute-parent.phl:
--------------------------------------------------------------------------------
1 | #hash((0 . #s((parent-gnode gnode 2) 0 - (1 8 63) ())) (1 . #s((parent-gnode gnode 2) 1 - (2 3 5 6 7 142 184 70) ())) (2 . #s((terminal-gnode (1 #t) gnode 2) 2 require #t)) (3 . #s((terminal-gnode (1 #t) gnode 2) 3 |"../core/common.rkt"| #t)) (5 . #s((terminal-gnode (1 #t) gnode 2) 5 |"../core/commands-common.rkt"| #t)) (6 . #s((terminal-gnode (1 #t) gnode 2) 6 |"../core/extractdata.rkt"| #t)) (7 . #s((terminal-gnode (1 #t) gnode 2) 7 |"../core/gnode.rkt"| #t)) (8 . #s((parent-gnode gnode 2) 8 - (9 10) ())) (9 . #s((terminal-gnode (1 #t) gnode 2) 9 provide #t)) (10 . #s((terminal-gnode (1 #t) gnode 2) 10 data #t)) (next-id . 203) (11 . #s((parent-gnode gnode 2) 11 - (12 13 35) (18))) (12 . #s((terminal-gnode (1 #t) gnode 2) 12 define #t)) (13 . #s((terminal-gnode (1 #t) gnode 2) 13 interlocute-parent #t)) (14 . #s((parent-gnode gnode 2) 14 - (25 27) ())) (15 . #s((terminal-gnode (1 #t) gnode 2) 15 event #t)) (16 . #s((terminal-gnode (1 #t) gnode 2) 16 - #t)) (17 . #s((function-gnode variable-gnode 1 gnode 2) 17 - 16 ())) (18 . #s((function-gnode variable-gnode 1 gnode 2) 18 - 14 (24))) (19 . #s((terminal-gnode (1 #t) gnode 2) 19 |"add-sibling.rkt"| #t)) (20 . #s((terminal-gnode (1 #t) gnode 2) 20 |"delete-link.rkt"| #t)) (21 . #s((terminal-gnode (1 #t) gnode 2) 21 |"paste.rkt"| #t)) (22 . #s((terminal-gnode (1 #t) gnode 2) 22 - #t)) (23 . #s((variable-gnode gnode 2) 23 event 24)) (24 . #s((argument-gnode (1 #t) gnode 2) 24 arger #t)) (25 . #s((terminal-gnode (1 #t) gnode 2) 25 begin #t)) (27 . #s((parent-gnode gnode 2) 27 - (28) ())) (28 . #s((parent-gnode gnode 2) 28 - (29 30 31) ())) (29 . #s((terminal-gnode (1 #t) gnode 2) 29 hash-ref #t)) (30 . #s((terminal-gnode (1 #t) gnode 2) 30 key-evs #t)) (31 . #s((terminal-gnode (1 #t) gnode 2) 31 |#\d| #t)) (32 . #s((parent-gnode gnode 2) 32 - (33) ())) (33 . #s((terminal-gnode (1 #t) gnode 2) 33 - #t)) (34 . #s((parent-gnode gnode 2) 34 - (36 49 75 56 59) (176 145 88 46 46 43))) (35 . #s((function-gnode variable-gnode 1 gnode 2) 35 interlocutor 34 (44))) (36 . #s((terminal-gnode (1 #t) gnode 2) 36 begin #t)) (37 . #s((parent-gnode gnode 2) 37 - (38 43) ())) (38 . #s((parent-gnode gnode 2) 38 - (39 40 47) (47))) (39 . #s((terminal-gnode (1 #t) gnode 2) 39 hash-ref #t)) (40 . #s((terminal-gnode (1 #t) gnode 2) 40 key-evs #t)) (41 . #s((terminal-gnode (1 #t) gnode 2) 41 |#\d| #t)) (42 . #s((terminal-gnode (1 #t) gnode 2) 42 - #t)) (43 . #s((variable-gnode gnode 2) 43 event 44)) (44 . #s((argument-gnode (1 #t) gnode 2) 44 arger #t)) (45 . #s((parent-gnode gnode 2) 45 - (46 52) ())) (46 . #s((function-gnode variable-gnode 1 gnode 2) 46 call-key 37 (48))) (47 . #s((variable-gnode gnode 2) 47 char 48)) (48 . #s((argument-gnode (1 #t) gnode 2) 48 arger #t)) (49 . #s((parent-gnode gnode 2) 49 - (188 50 43) ())) (50 . #s((terminal-gnode (1 #t) gnode 2) 50 |"delete-link"| #t)) (51 . #s((terminal-gnode (1 #t) gnode 2) 51 - #t)) (52 . #s((terminal-gnode (1 #t) gnode 2) 52 |#\A| #t)) (53 . #s((parent-gnode gnode 2) 53 - (196 55 43) ())) (54 . #s((terminal-gnode (1 #t) gnode 2) 54 - #t)) (55 . #s((terminal-gnode (1 #t) gnode 2) 55 |"add-sibling"| #t)) (56 . #s((parent-gnode gnode 2) 56 - (199 58 43) ())) (57 . #s((terminal-gnode (1 #t) gnode 2) 57 - #t)) (58 . #s((terminal-gnode (1 #t) gnode 2) 58 |"enter-paste"| #t)) (59 . #s((parent-gnode gnode 2) 59 - (60 43 62) ())) (60 . #s((terminal-gnode (1 #t) gnode 2) 60 handle-paste #t)) (61 . #s((terminal-gnode (1 #t) gnode 2) 61 - #t)) (62 . #s((terminal-gnode (1 #t) gnode 2) 62 |#\j| #t)) (63 . #s((parent-gnode gnode 2) 63 - (64 65 66) ())) (65 . #s((terminal-gnode (1 #t) gnode 2) 65 data #t)) (64 . #s((terminal-gnode (1 #t) gnode 2) 64 define #t)) (67 . #s((terminal-gnode (1 #t) gnode 2) 67 list #t)) (66 . #s((parent-gnode gnode 2) 66 - (67 179 35) (35))) (69 . #s((terminal-gnode (1 #t) gnode 2) 69 interlocute-parent #t)) (68 . #s((terminal-gnode (1 #t) gnode 2) 68 |#\I| #t)) (71 . #s((terminal-gnode (1 #t) gnode 2) 71 except-in #t)) (70 . #s((parent-gnode gnode 2) 70 - (71 21 72) ())) (73 . #s((terminal-gnode (1 #t) gnode 2) 73 - #t)) (72 . #s((terminal-gnode (1 #t) gnode 2) 72 data #t)) (75 . #s((parent-gnode gnode 2) 75 - (76 77 93 91) ())) (74 . #s((terminal-gnode (1 #t) gnode 2) 74 - #t)) (77 . #s((parent-gnode gnode 2) 77 - (78 88) ())) (76 . #s((terminal-gnode (1 #t) gnode 2) 76 if #t)) (79 . #s((parent-gnode gnode 2) 79 - (80 81) ())) (78 . #s((terminal-gnode (1 #t) gnode 2) 78 zero? #t)) (81 . #s((parent-gnode gnode 2) 81 - (82 83) ())) (80 . #s((terminal-gnode (1 #t) gnode 2) 80 last #t)) (83 . #s((parent-gnode gnode 2) 83 - (84 85) ())) (82 . #s((terminal-gnode (1 #t) gnode 2) 82 node-laddr #t)) (85 . #s((parent-gnode gnode 2) 85 - (86 87) ())) (84 . #s((terminal-gnode (1 #t) gnode 2) 84 utterance-node #t)) (87 . #s((terminal-gnode (1 #t) gnode 2) 87 Selected-tree #t)) (86 . #s((terminal-gnode (1 #t) gnode 2) 86 whole-tree-selection-u #t)) (89 . #s((terminal-gnode (1 #t) gnode 2) 89 - #t)) (88 . #s((variable-gnode gnode 2) 88 laddr-last 79)) (91 . #s((parent-gnode gnode 2) 91 - (92 163 53) ())) (90 . #s((terminal-gnode (1 #t) gnode 2) 90 - #t)) (93 . #s((parent-gnode gnode 2) 93 - (94 124 98) ())) (92 . #s((terminal-gnode (1 #t) gnode 2) 92 begin #t)) (95 . #s((parent-gnode gnode 2) 95 - (190 97 43) ())) (94 . #s((terminal-gnode (1 #t) gnode 2) 94 begin #t)) (97 . #s((terminal-gnode (1 #t) gnode 2) 97 |"semantic-up"| #t)) (96 . #s((terminal-gnode (1 #t) gnode 2) 96 - #t)) (99 . #s((terminal-gnode (1 #t) gnode 2) 99 - #t)) (98 . #s((parent-gnode gnode 2) 98 - (192 100 193) ())) (101 . #s((terminal-gnode (1 #t) gnode 2) 101 - #t)) (100 . #s((terminal-gnode (1 #t) gnode 2) 100 |"add-child"| #t)) (124 . #s((parent-gnode gnode 2) 124 - (126 145 95) ())) (127 . #s((parent-gnode gnode 2) 127 - (128 156) ())) (126 . #s((terminal-gnode (1 #t) gnode 2) 126 when #t)) (130 . #s((terminal-gnode (1 #t) gnode 2) 130 utterance-args #t)) (131 . #s((parent-gnode gnode 2) 131 - (146 147 150) ())) (128 . #s((terminal-gnode (1 #t) gnode 2) 128 length #t)) (129 . #s((parent-gnode gnode 2) 129 - (130 131) ())) (134 . #s((parent-gnode gnode 2) 134 - (135 136) ())) (135 . #s((terminal-gnode (1 #t) gnode 2) 135 whole-tree-selection-u #t)) (132 . #s((terminal-gnode (1 #t) gnode 2) 132 utterance-parent #t)) (133 . #s((terminal-gnode (1 #t) gnode 2) 133 - #t)) (138 . #s((parent-gnode gnode 2) 138 - (139 176 141) ())) (139 . #s((terminal-gnode (1 #t) gnode 2) 139 > #t)) (136 . #s((terminal-gnode (1 #t) gnode 2) 136 Selected-tree #t)) (137 . #s((terminal-gnode (1 #t) gnode 2) 137 Selected-tree #t)) (142 . #s((terminal-gnode (1 #t) gnode 2) 142 |"../core/disp.rkt"| #t)) (143 . #s((terminal-gnode (1 #t) gnode 2) 143 whole-tree-selection-u #t)) (140 . #s((terminal-gnode (1 #t) gnode 2) 140 - #t)) (141 . #s((terminal-gnode (1 #t) gnode 2) 141 1 #t)) (146 . #s((terminal-gnode (1 #t) gnode 2) 146 utterance-parent #t)) (147 . #s((parent-gnode gnode 2) 147 - (148 149) ())) (144 . #s((terminal-gnode (1 #t) gnode 2) 144 Selected-tree #t)) (145 . #s((variable-gnode gnode 2) 145 parent-args 138)) (150 . #s((terminal-gnode (1 #t) gnode 2) 150 Selected-tree #t)) (151 . #s((parent-gnode gnode 2) 151 - (152 145) ())) (148 . #s((terminal-gnode (1 #t) gnode 2) 148 whole-tree-selection-u #t)) (149 . #s((terminal-gnode (1 #t) gnode 2) 149 Selected-tree #t)) (152 . #s((terminal-gnode (1 #t) gnode 2) 152 displayln #t)) (153 . #s((terminal-gnode (1 #t) gnode 2) 153 - #t)) (158 . #s((parent-gnode gnode 2) 158 - (159 160) ())) (159 . #s((terminal-gnode (1 #t) gnode 2) 159 displayln #t)) (156 . #s((parent-gnode gnode 2) 156 - (157 129) ())) (157 . #s((terminal-gnode (1 #t) gnode 2) 157 begin #t)) (162 . #s((terminal-gnode (1 #t) gnode 2) 162 Selected-tree #t)) (163 . #s((parent-gnode gnode 2) 163 - (165 166 170) ())) (160 . #s((parent-gnode gnode 2) 160 - (161 162) ())) (161 . #s((terminal-gnode (1 #t) gnode 2) 161 whole-tree-selection-u #t)) (166 . #s((parent-gnode gnode 2) 166 - (167 173 88) ())) (167 . #s((terminal-gnode (1 #t) gnode 2) 167 = #t)) (165 . #s((terminal-gnode (1 #t) gnode 2) 165 unless #t)) (170 . #s((parent-gnode gnode 2) 170 - (194 172 43) ())) (171 . #s((terminal-gnode (1 #t) gnode 2) 171 - #t)) (168 . #s((terminal-gnode (1 #t) gnode 2) 168 - #t)) (169 . #s((terminal-gnode (1 #t) gnode 2) 169 - #t)) (174 . #s((terminal-gnode (1 #t) gnode 2) 174 - #t)) (175 . #s((terminal-gnode (1 #t) gnode 2) 175 1 #t)) (172 . #s((terminal-gnode (1 #t) gnode 2) 172 |"semantic-left"| #t)) (173 . #s((parent-gnode gnode 2) 173 - (174 176 175) ())) (178 . #s((terminal-gnode (1 #t) gnode 2) 178 |"command-line.rkt"| #t)) (179 . #s((parent-gnode gnode 2) 179 - (180 181) ())) (176 . #s((variable-gnode gnode 2) 176 parent-args-length 127)) (177 . #s((terminal-gnode (1 #t) gnode 2) 177 - #t)) (182 . #s((terminal-gnode (1 #t) gnode 2) 182 |#\I| #t)) (183 . #s((terminal-gnode (1 #t) gnode 2) 183 interlocute-parent #t)) (180 . #s((terminal-gnode (1 #t) gnode 2) 180 quote #t)) (181 . #s((parent-gnode gnode 2) 181 - (182 183) ())) (186 . #s((terminal-gnode (1 #t) gnode 2) 186 |"command-line.rkt"| #t)) (187 . #s((terminal-gnode (1 #t) gnode 2) 187 data #t)) (184 . #s((parent-gnode gnode 2) 184 - (185 186 187) ())) (185 . #s((terminal-gnode (1 #t) gnode 2) 185 except-in #t)) (190 . #s((terminal-gnode (1 #t) gnode 2) 190 process-command #t)) (191 . #s((terminal-gnode (1 #t) gnode 2) 191 - #t)) (188 . #s((terminal-gnode (1 #t) gnode 2) 188 process-command #t)) (189 . #s((terminal-gnode (1 #t) gnode 2) 189 - #t)) (195 . #s((terminal-gnode (1 #t) gnode 2) 195 - #t)) (194 . #s((terminal-gnode (1 #t) gnode 2) 194 process-command #t)) (193 . #s((terminal-gnode (1 #t) gnode 2) 193 event #t)) (192 . #s((terminal-gnode (1 #t) gnode 2) 192 process-command #t)) (199 . #s((terminal-gnode (1 #t) gnode 2) 199 process-command #t)) (197 . #s((terminal-gnode (1 #t) gnode 2) 197 - #t)) (196 . #s((terminal-gnode (1 #t) gnode 2) 196 process-command #t)) (200 . #s((terminal-gnode (1 #t) gnode 2) 200 - #t)))


--------------------------------------------------------------------------------
/commands/movement.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "../core/common.rkt")
  4 | (require "../core/disp.rkt")
  5 | 
  6 | (provide data)
  7 | 
  8 | (define (nth-child n event)
  9 |  (if (> (length (utterance-args (whole-tree-selection-u Selected-tree))) n)
 10 |   (select (list-ref (utterance-args (whole-tree-selection-u Selected-tree)) n) Selected-tree)
 11 |   (select (last (utterance-args (whole-tree-selection-u Selected-tree))) Selected-tree))
 12 |  (generate-utterance-tree Selected-tree)
 13 |  (send Thecanvas on-paint))
 14 | 
 15 | (define (new-tree event)
 16 |  (add-to-screen (node-data (utterance-node (whole-tree-selection-u Selected-tree))) (whole-tree-childfunc Selected-tree))
 17 |  (generate-utterance-tree Selected-tree)
 18 |  (send Thecanvas on-paint))
 19 | 
 20 | (define (replace-major-tree event)
 21 |  (let* ((tree (cadr Trees))
 22 |         (n (root->node (node-data (utterance-node (whole-tree-selection-u Selected-tree))) (whole-tree-childfunc tree) '())))
 23 |   (set-whole-tree-n-tree! tree n)
 24 |   (set-whole-tree-utterance-tree! tree ((v11n-node->v11n-utterance (whole-tree-v11n tree)) (whole-tree-n-tree tree) tree))
 25 | ;  (set-whole-tree-utterance-tree! tree ((v11n-node->v11n-utterance (whole-tree-v11n tree)) (whole-tree-n-tree tree) 0 0 0 0 '() tree))
 26 |   (set-whole-tree-selection! tree '())
 27 |   (set-whole-tree-offset-x! tree 0)
 28 |   (set-whole-tree-offset-y! tree 0)
 29 |   (set-selected-tree tree))
 30 |  (generate-utterance-tree Selected-tree)
 31 |  (send Thecanvas on-paint))
 32 | 
 33 | (define (select-new-tree event)
 34 |  (set-selected-tree
 35 |   (if (send event get-shift-down)
 36 |    (let ((r (member Selected-tree (reverse Trees))))
 37 |     (if (null? (cdddr r))
 38 |      (last Trees)
 39 |      (cadr r)))
 40 |    (let ((r (member Selected-tree Trees)))
 41 |     (if (null? (cdr r))
 42 |      (if (null? (cdr Trees))
 43 |       (car Trees)
 44 |       (caddr Trees))
 45 |      (cadr r)))))
 46 |  (generate-utterance-tree Selected-tree)
 47 |  (send Thecanvas on-paint))
 48 | 
 49 | (define (zoom-out event)
 50 |  (set-whole-tree-offset-x! Selected-tree (- (cartesian-utterance-y (whole-tree-selection-u Selected-tree))))
 51 |  (set-whole-tree-offset-y! Selected-tree (- (cartesian-utterance-x (whole-tree-selection-u Selected-tree))))
 52 |  (set-whole-tree-zoom! Selected-tree (if (= (whole-tree-zoom Selected-tree) 1) (if VERTICAL (/ (whole-tree-h Selected-tree) (cartesian-utterance-h (whole-tree-selection-u Selected-tree))) (/ (whole-tree-w Selected-tree) (cartesian-utterance-w (whole-tree-selection-u Selected-tree) ))) 1))
 53 |  (send Thecanvas on-paint))
 54 | 
 55 | (define (go dir tree)
 56 |  (let ((new-sel (apply (v11n-find-utterance (whole-tree-v11n tree)) (whole-tree-utterance-tree tree)
 57 |                  (cond
 58 |                   ((eq? dir 'left)
 59 |                    (list (+ (cartesian-utterance-x (whole-tree-selection-u tree)) -1) (cartesian-utterance-y (whole-tree-selection-u tree)) tree))
 60 |                   ((eq? dir 'down)
 61 |                    (list (cartesian-utterance-x (whole-tree-selection-u tree)) (+ (cartesian-utterance-y (whole-tree-selection-u tree)) (cartesian-utterance-h (whole-tree-selection-u tree)) 1) tree))
 62 |                   ((eq? dir 'up)
 63 |                    (list (cartesian-utterance-x (whole-tree-selection-u tree)) (+ (cartesian-utterance-y (whole-tree-selection-u tree)) -1) tree))
 64 |                   ((eq? dir 'right)
 65 |                    (list (+ (cartesian-utterance-x (whole-tree-selection-u tree)) (cartesian-utterance-w (whole-tree-selection-u tree)) 1) (cartesian-utterance-y (whole-tree-selection-u tree)) tree))))))
 66 |  (select (if new-sel new-sel (whole-tree-selection-u tree)) tree))
 67 |  (generate-utterance-tree tree)
 68 |  (send Thecanvas on-paint))
 69 | 
 70 | (define data
 71 |  (list
 72 |     '(#\n new-tree) new-tree
 73 |     '(#\N relace-major-tree) replace-major-tree
 74 |     '(#\tab cycle-tree) select-new-tree
 75 |     '(#\q close-tree) (lambda (_) (remove-tree Selected-tree))
 76 |     '(#\h left) (lambda (_) (go 'left Selected-tree))
 77 |     '(#\j down) (lambda (_) (go 'down Selected-tree))
 78 |     '(#\k up) (lambda (_) (go 'up Selected-tree))
 79 |     '(#\l right) (lambda (_) (go 'right Selected-tree))
 80 |     '(#\A semantic-left) (lambda (_) (semantic-go 'left Selected-tree))
 81 |     '(#\S semantic-down) (lambda (_) (semantic-go 'down Selected-tree))
 82 |     '(#\W semantic-up) (lambda (_) (semantic-go 'up Selected-tree))
 83 |     '(#\D semantic-right) (lambda (_) (semantic-go 'right Selected-tree))
 84 |     '(#\o shallow-open) (lambda (_) (open-u (whole-tree-selection-u Selected-tree) #f Selected-tree) (send Thecanvas on-paint))
 85 |     '(#\c shallow-close) (lambda (_) (close-u (whole-tree-selection-u Selected-tree) #f Selected-tree) (send Thecanvas on-paint))
 86 |     '(#\O deep-open) (lambda (_) (open-u (whole-tree-selection-u Selected-tree) #t Selected-tree) (send Thecanvas on-paint))
 87 |     '(#\C deep-close) (lambda (_) (close-u (whole-tree-selection-u Selected-tree) #t Selected-tree) (send Thecanvas on-paint))
 88 |     '(#\z zoom) zoom-out
 89 |     '(#\V cycle-v11n) cycle-v11n
 90 |     '(#\0 0) (curry nth-child 0)
 91 |     '(#\1 1) (curry nth-child 1)
 92 |     '(#\2 2) (curry nth-child 2)
 93 |     '(#\3 3) (curry nth-child 3)
 94 |     '(#\4 4) (curry nth-child 4)
 95 |     '(#\5 5) (curry nth-child 5)
 96 |     '(#\6 6) (curry nth-child 6)
 97 |     '(#\7 7) (curry nth-child 7)
 98 |     '(#\8 8) (curry nth-child 8)
 99 |     '(#\9 9) (curry nth-child 9)
100 |     '(wheel-up) (lambda (event)
101 |                (if (or (send event get-control-down) (send event get-shift-down) (send event get-meta-down))
102 |                 (begin
103 |                  (if (send event get-control-down)
104 |                   (set-VAR1 (max (min (+ VAR1 VAR1OFFSET) VAR1MAX) VAR1MIN))
105 |                   '())
106 |                  (if (send event get-shift-down)
107 |                   (set-VAR2 (max (min (+ VAR2 VAR2OFFSET) VAR2MAX) VAR2MIN))
108 |                   '())
109 |                  (if (send event get-meta-down)
110 |                   (set-VAR3 (max (min (+ VAR3 VAR3OFFSET) VAR3MAX) VAR3MIN))
111 |                   '())
112 |                  (generate-utterance-tree Selected-tree))
113 |                 ((v11n-wheel (whole-tree-v11n Selected-tree)) 'up event))
114 |                (send Thecanvas on-paint))
115 |     '(wheel-down) (lambda (event)
116 |                  (if (or (send event get-control-down) (send event get-shift-down) (send event get-meta-down))
117 |                   (begin
118 |                    (if (send event get-control-down)
119 |                     (set-VAR1 (max (min (- VAR1 VAR1OFFSET) VAR1MAX) VAR1MIN))
120 |                     '())
121 |                    (if (send event get-shift-down)
122 |                     (set-VAR2 (max (min (- VAR2 VAR2OFFSET) VAR2MAX) VAR2MIN))
123 |                     '())
124 |                    (if (send event get-meta-down)
125 |                     (set-VAR3 (max (min (- VAR3 VAR3OFFSET) VAR3MAX) VAR3MIN))
126 |                     '())
127 |                    (generate-utterance-tree Selected-tree))
128 |                   ((v11n-wheel (whole-tree-v11n Selected-tree)) 'down event))
129 |                  (send Thecanvas on-paint))
130 |     '(wheel-left) (lambda (event) ((v11n-wheel (whole-tree-v11n Selected-tree)) 'left event) (send Thecanvas on-paint))
131 |     '(wheel-right) (lambda (event) ((v11n-wheel (whole-tree-v11n Selected-tree)) 'right event) (send Thecanvas on-paint))
132 |     ))
133 | 
134 | 


--------------------------------------------------------------------------------
/commands/paste.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/commands-common.rkt")
 5 | (require "../core/extractdata.rkt")
 6 | (require "../core/gnode.rkt")
 7 | (require "../core/disp.rkt")
 8 | 
 9 | (provide data handle-paste)
10 | 
11 | (define (paste event)
12 |  (enter-paste-mode))
13 | 
14 | (define (handle-paste event (char '()))
15 |  (with
16 |   ((let ((c (if (null? char) (send event get-key-code) char)))
17 |     (cond
18 |      ((eq? c #\j)
19 |       (make-paste-below (selected-id Selected-tree) (whole-tree-selection Selected-tree))
20 |       (exit-paste-mode))
21 |      ((eq? c #\h)
22 |       (let* ((parent (selected-parent-id Selected-tree))
23 |              (child (selected-id Selected-tree)))
24 |        (make-paste parent child))
25 |       (exit-paste-mode))
26 |      ((eq? c #\l)
27 |       (let* ((parent (selected-parent-id Selected-tree))
28 |              (child (selected-id Selected-tree)))
29 |        (make-paste parent child))
30 |       (exit-paste-mode))
31 |      ((eq? c 'escape)
32 |       (exit-paste-mode))
33 |      (#t '()))))
34 | 
35 |   (make-paste (parent-id child-id)
36 |    (if (member child-id (parent-gnode-childs (hash-ref G parent-id)))
37 |     (updater
38 |      #:graph-changer (lambda ()
39 |                       (let ((pgn (hash-ref G parent-id)))
40 | 		       (set-G (graph-add-child-after G parent-id child-id (pop-clipboard)))))
41 | ;		       (set-G (hash-set G parent-id (parent-gnode parent-id (gnode-name pgn) (replace child-id (list child-id (pop-clipboard)) (parent-gnode-childs pgn)) (parent-gnode-vars pgn))))))
42 |      #:open-updater  (lambda ()
43 |                       (for-all-trees
44 |                        (lambda (tree)
45 |                         (set-whole-tree-open! tree
46 |                                               (set-union
47 |                                                (list->set
48 |                                                 (set-map
49 |                                                  (whole-tree-open tree)
50 |                                                  (curry adjust-laddr child-id parent-id
51 |                                                         (last (whole-tree-selection Selected-tree))
52 |                                                         (whole-tree-utterance-tree tree))))
53 |                                                (set (append (drop-right (whole-tree-selection Selected-tree) 1) (list (+ 1 (last (whole-tree-selection Selected-tree)))))))))))
54 |      #:selection-updater (lambda () (semantic-go 'right Selected-tree)))
55 |     '()))
56 | 
57 |   (make-paste-below (parent-id parent-laddr)
58 |    (updater
59 |     #:graph-changer     (lambda ()
60 |                          (let ((pgn (hash-ref G parent-id)))
61 | 			  (set-G (graph-add-child-beg G parent-id (pop-clipboard)))))
62 |     #:open-updater      (lambda ()
63 |                          (set-whole-tree-open! Selected-tree (set-union (whole-tree-open Selected-tree) (set parent-laddr))))
64 |     #:selection-updater (lambda ()
65 |                          (semantic-go 'down Selected-tree))))))
66 | 
67 | (define data
68 |  (list
69 |   '(#\p enter-paste) paste
70 |   '(paste) handle-paste))
71 | 
72 | 


--------------------------------------------------------------------------------
/commands/reify.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | (require "../core/compiler.rkt")
 7 | 
 8 | (provide data)
 9 | 
10 | (define (reify-code event) (display (reify G 0 #f)) (newline))
11 | 
12 | (define data
13 |  (list '(#\r reify) reify-code))
14 | 
15 | 


--------------------------------------------------------------------------------
/commands/run-code.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | (require "../core/compiler.rkt")
 7 | 
 8 | (provide data)
 9 | 
10 | (define (run-code event)
11 |  (let ((code (reify G 0 #t))
12 |        (ns (make-base-namespace)))
13 |   (print code) (newline)
14 |   (eval '(require racket "graph.ss") ns)
15 |   (eval '(define Next-r -1) ns)
16 |   (eval '(define stack '()) ns)
17 |   (eval '(define h (hash)) ns)
18 |   (eval code ns)
19 |   (set-runtime-vals (eval 'h ns))
20 |   (update-data)
21 |   (update-childfuncs child-fun)))
22 | 
23 | (define data
24 |  (list '(#\G run) run-code))
25 | 
26 | 


--------------------------------------------------------------------------------
/commands/scope.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require (except-in "../core/extractdata.rkt" LINK1 LINK1PARENT LINK1ADDR))
 5 | (require "../core/gnode.rkt")
 6 | (require "../core/disp.rkt")
 7 | 
 8 | (provide data)
 9 | 
10 | (define LINK1 '())
11 | (define LINK1PARENT '())
12 | (define LINK1ADDR '())
13 | 
14 | (define (set-scope event)
15 |  (set! LINK1 (selected-id Selected-tree))
16 |  (set! LINK1ADDR (whole-tree-selection Selected-tree))
17 |  (enter-scope-mode))
18 | 
19 | (define (handle-scope event)
20 |  (with
21 |   ((let ((c (send event get-key-code)))
22 |     (cond
23 |      ((member c '(#\h #\j #\k #\l))
24 |       ((hash-ref key-evs c) event))
25 |      ((eq? c #\return)
26 |       (make-scope))
27 |      ((eq? c 'escape)
28 |       (exit-scope-mode))
29 |      (#t '()))))
30 | 
31 |   (make-scope ()
32 |    (let* ((link2 (selected-id Selected-tree)))
33 |     (updater
34 |      #:graph-changer     (lambda ()
35 |                           (let ((l2gn (hash-ref G link2)))
36 | 			   (purge-var LINK1)
37 | 			   (set-G (hash-set G link2 (parent-gnode link2 (gnode-name l2gn) (parent-gnode-childs l2gn) (cons LINK1 (parent-gnode-vars l2gn)))))))
38 |      #:selection-updater (lambda ()
39 |                           (exit-scope-mode)))))))
40 | 
41 | (define (purge-var id)
42 |  (hash-for-each
43 |   G
44 |   (lambda (id-in gn)
45 |    (if (parent-gnode? gn)
46 |     (set-G (hash-set G id-in (parent-gnode id-in (gnode-name gn) (parent-gnode-childs gn) (remove id (parent-gnode-vars gn)))))
47 |     gn))))
48 | 
49 | (define data
50 |  (list
51 |   '(#\s enter-scope) set-scope
52 |   '(scope) handle-scope))
53 | 
54 | 


--------------------------------------------------------------------------------
/commands/search.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | (require "../core/disp.rkt")
 7 | 
 8 | (provide data search-bound-variables)
 9 | 
10 | (define (search-bound-variables data text)
11 |  (let ((regex (regexp text))
12 |        (texts (cadddr (cddr data))))
13 |   (filter (lambda (t) (regexp-match? regex (format "~a" (cadr t)))) texts)))
14 | 
15 | (define Search-text "")
16 | 
17 | (define (search event)
18 |  (set! Search-text "")
19 |  (enter-search-mode))
20 | 
21 | (define (handle-search event)
22 |  (with
23 |   ((let ((c (send event get-key-code)))
24 |     (cond
25 |      ((and (eq? c #\n) (send event get-control-down))
26 |       (scroll-search-results)
27 |       (show-search-tree get-rep)
28 |       (send Thecanvas on-paint))
29 |      ((and (char? c) (not (char-whitespace? c)) (not (char-iso-control? c)) (not (member c '(#\( #\) #\[ #\] #\{ #\} #\" #\, #\' #\` #\; #\# #\| #\\))))
30 |       (set! Search-text (string-append Search-text (string (send event get-key-code))))
31 |       (show-results))
32 |      ((eq? c #\backspace)
33 |       (set! Search-text (substring Search-text 0 (- (string-length Search-text) 1)))
34 |       (show-results))
35 |      ((eq? c #\return)
36 |       (exit-search-mode))
37 |      ((eq? c 'escape)
38 |       (remove-search-tree)
39 |       (send Thecanvas on-paint)
40 |       (exit-search-mode))
41 |      (#t '()))))
42 | 
43 |   (show-results ()
44 |    (set-search-results (search-text Search-text))
45 |    (show-search-tree get-rep)
46 |    (set-info Search-text)
47 |    (send Thecanvas on-paint))))
48 | 
49 | (define (search-text text)
50 |  (let* ((regex (regexp text))
51 |         (texts (hash-map (hash-remove G 'next-id)  (lambda (id gn) (list id '() (gnode-name gn)))))
52 |         (texts2 (filter (lambda (text) (not (null? text))) texts)))
53 |   (filter (lambda (t) (regexp-match? regex (format "~a" (caddr t)))) texts2)))
54 | 
55 | (define data
56 |  (list
57 |   '(#\/ enter-search) search
58 |   '(search) handle-search))
59 | 


--------------------------------------------------------------------------------
/commands/undo-redo.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/disp.rkt")
 6 | (require "../core/gnode.rkt")
 7 | 
 8 | (provide data)
 9 | 
10 | (define (undo-pop event)
11 |  (if (null? UNDOSTACK)
12 |   '()
13 |   (begin
14 |    (set-REDOSTACK (cons (state G (copy-trees) (get-selected-tree-index)) REDOSTACK))
15 |    (set-G (state-graph (car UNDOSTACK)))
16 |    (set-Trees (state-trees (car UNDOSTACK)))
17 |    (set-selected-tree (list-ref Trees (state-selected-tree (car UNDOSTACK))))
18 |    (set-UNDOSTACK (cdr UNDOSTACK))
19 |    (update-data)
20 |    (update-childfuncs child-fun))))
21 | 
22 | (define (redo-pop event)
23 |  (if (null? REDOSTACK)
24 |   '()
25 |   (begin
26 |    (set-UNDOSTACK (cons (state G (copy-trees) (get-selected-tree-index)) UNDOSTACK))
27 |    (set-G (state-graph (car REDOSTACK)))
28 |    (set-Trees (state-trees (car REDOSTACK)))
29 |    (set-selected-tree (list-ref Trees (state-selected-tree (car REDOSTACK))))
30 |    (set-REDOSTACK (cdr REDOSTACK))
31 |    (update-data)
32 |    (update-childfuncs child-fun))))
33 | 
34 | (define data
35 |  (list
36 |   '(#\u undo) undo-pop
37 |   '(#\R redo) redo-pop))
38 | 
39 | 
40 | 


--------------------------------------------------------------------------------
/commands/write-to-file.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "../core/common.rkt")
 4 | (require "../core/extractdata.rkt")
 5 | (require "../core/gnode.rkt")
 6 | 
 7 | (provide data)
 8 | 
 9 | (define (write-g-to-file event)
10 |  (graph->file G))
11 | 
12 | (define data
13 |  (list '(f2 write w) write-g-to-file))
14 | 
15 | 


--------------------------------------------------------------------------------
/core/README.md:
--------------------------------------------------------------------------------
1 | Core
2 | ====
3 | 
4 | These are the core files for both the phlisp language and the phlisped graphical editor.
5 | 
6 | 


--------------------------------------------------------------------------------
/core/commands-common.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "common.rkt")
 4 | (require "disp.rkt")
 5 | (require "extractdata.rkt")
 6 | (require "gnode.rkt")
 7 | 
 8 | (provide (all-defined-out))
 9 | 
10 | (struct event (graph-changer ids-consumed open-updater selection-updater))
11 | 
12 | (define (graph-add-terminal-gnode g id)
13 |  (hash-set g id (terminal-gnode id '-)))
14 | 
15 | (define (graph-add-child-beg g id cid)
16 |  (let ((gn (hash-ref g id)))
17 |   (hash-set g id (parent-gnode id (gnode-name gn) (cons cid (if (parent-gnode? gn) (parent-gnode-childs gn) '())) (if (parent-gnode? gn) (parent-gnode-vars gn) '())))))
18 |         
19 | (define (graph-add-child-after g id cid nid)
20 |  (let ((gn (hash-ref g id)))
21 |   (hash-set g id (parent-gnode id (gnode-name gn) (replace cid (list cid nid) (if (parent-gnode? gn) (parent-gnode-childs gn) '())) (if (parent-gnode? gn) (parent-gnode-vars gn) '())))))
22 | 
23 | (define (event-wrapper ev)
24 |  (lambda (e)
25 |   (let* ((id (selected-id Selected-tree))
26 |          (parent-id (if (zero? id) 0 (selected-parent-id Selected-tree))))
27 |    (updater
28 |     #:graph-changer
29 |     (lambda ()
30 |      (set-G ((event-graph-changer ev) G id parent-id )))
31 |     #:open-updater
32 |     (lambda ()
33 |      (for-all-trees (lambda (tree) (set-whole-tree-open! tree ((event-open-updater ev) tree id parent-id)))))
34 |     #:selection-updater
35 |     (lambda ()
36 |      ((event-selection-updater ev))
37 |      (set-Next-id (+ Next-id (event-ids-consumed ev))))))))
38 | 
39 | (define (distributor h event)
40 |  (let ((c (send event get-key-code)))
41 |   (if (hash-has-key? h c)
42 |    ((hash-ref h c) event)
43 |    (when (hash-has-key? h 'else)
44 |     ((hash-ref h 'else) event)))))
45 | 
46 | 


--------------------------------------------------------------------------------
/core/common.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require sgl sgl/gl)
  4 | 
  5 | (require ffi/unsafe ffi/unsafe/define ffi/unsafe/cvector)
  6 | 
  7 | (define-ffi-definer define-ftgl (ffi-lib "libftgl"))
  8 | 
  9 | (define _FTGLfont (_cpointer 'FTGLfont))
 10 | (define _GLuint _uint)
 11 | (define-ftgl ftglCreatePixmapFont (_fun _path -> _FTGLfont))
 12 | (define-ftgl ftglCreateBitmapFont (_fun _path -> _FTGLfont))
 13 | (define-ftgl ftglCreateBufferFont (_fun _path -> _FTGLfont))
 14 | (define-ftgl ftglCreateTextureFont (_fun _path -> _FTGLfont))
 15 | (define-ftgl ftglCreateOutlineFont (_fun _path -> _FTGLfont))
 16 | (define-ftgl ftglCreatePolygonFont (_fun _path -> _FTGLfont))
 17 | (define-ftgl ftglCreateExtrudeFont (_fun _path -> _FTGLfont))
 18 | (define-ftgl ftglSetFontFaceSize (_fun _FTGLfont _int _int -> _void))
 19 | (define-ftgl ftglGetFontLineHeight (_fun _FTGLfont -> _float))
 20 | (define-ftgl ftglGetFontAdvance (_fun _FTGLfont _string -> _float))
 21 | (define-ftgl ftglRenderFont (_fun _FTGLfont _string _int -> _void))
 22 | (define-ftgl ftglDestroyFont (_fun _FTGLfont -> _void))
 23 | 
 24 | (define-ffi-definer define-soil (ffi-lib "libsoil"))
 25 | 
 26 | (define-soil SOIL_load_OGL_texture (_fun _path _int _uint _uint -> _uint))
 27 | (define-soil SOIL_last_result (_fun -> _string))
 28 | 
 29 | (provide (all-defined-out))
 30 | 
 31 | (define-syntax (with stx)
 32 |  (let* ((l (syntax->datum stx))
 33 |         (body (cadr l))
 34 |         (defs (cddr l))
 35 |         (lams (map (lambda (def) `(,(car def) (lambda ,(cadr def) ,@(cddr def)))) defs)))
 36 |   (datum->syntax stx `(letrec ,lams ,@body))))
 37 | 
 38 | (struct node (data laddr prom-args text-func) #:transparent)
 39 | (struct utterance (node args clr) #:transparent)
 40 | (struct cartesian-utterance utterance (x y w h text-w text-h))
 41 | (struct whole-tree (n-tree childfunc utterance-tree open selection x y w h v11n offset-x offset-y zoom) #:mutable)
 42 | (struct v11n (paint-tree node->v11n-utterance find-utterance wheel))
 43 | 
 44 | (define Selected-tree '())
 45 | (define (set-selected-tree tree)
 46 |  (set! Selected-tree tree))
 47 | 
 48 | (define Font #f)
 49 | (define (set-font f)
 50 |  (set! Font f))
 51 | 
 52 | (define PADDING 5)
 53 | (define VERTICAL #f)
 54 | (define CELLHEIGHT 25)
 55 | (define SCROLLDIST 100)
 56 | 
 57 | (define node-args (compose force node-prom-args))
 58 | 
 59 | (define (node-width n tree)
 60 |  (if VERTICAL (box-width ((node-text-func n) (node-data n))) (node-maj-dim n tree)))
 61 | 
 62 | (define (node-height n tree)
 63 |  (if VERTICAL (node-maj-dim n tree) CELLHEIGHT))
 64 | 
 65 | (define (node-maj-dim n tree)
 66 |  (if (closed? n tree)
 67 |   (box-maj-dim ((node-text-func n) (node-data n)))
 68 |   (max
 69 |    (box-maj-dim ((node-text-func n) (node-data n)))
 70 |    (foldl
 71 |     +
 72 |     0
 73 |     (map (lambda (arg) (node-maj-dim arg tree)) (node-args n))))))
 74 | 
 75 | (define (whole-tree-selection-u tree)
 76 |  (find-utterance-from-laddr-safe (whole-tree-utterance-tree tree) (whole-tree-selection tree)))
 77 | 
 78 | (define (find-utterance-from-laddr-safe tree laddr)
 79 |  (if (null? laddr)
 80 |   tree
 81 |   (if (> (length (utterance-args tree)) (car laddr))
 82 |    (find-utterance-from-laddr-safe (list-ref (utterance-args tree) (car laddr)) (cdr laddr))
 83 |    #f)))
 84 | 
 85 | (define (draw-rectangle clr x y w h)
 86 |  (gl-color (/ (car clr) 255) (/ (cadr clr) 255) (/ (caddr clr) 255))
 87 | 
 88 |  (gl-begin 'quads)
 89 |  (gl-vertex x (- y) -1.01)
 90 |  (gl-vertex (+ x w) (- y) -1.01)
 91 |  (gl-vertex (+ x w) (- (+ y h)) -1.01)
 92 |  (gl-vertex x (- (+ y h)) -1.01)
 93 |  (gl-end))
 94 | 
 95 | (define (draw-text text x y clr (rot 0))
 96 |  (gl-color (/ (car clr) 255) (/ (cadr clr) 255) (/ (caddr clr) 255))
 97 |  (gl-push-matrix)
 98 |  (gl-translate x (- y) -1.01)
 99 |  (gl-rotate rot 0 0 -1.1)
100 |  (ftglRenderFont Font text 65535)
101 |  (gl-pop-matrix))
102 | 
103 | (define (whole-tree-dim tree)
104 |  (list (whole-tree-x tree) (whole-tree-y tree) (whole-tree-w tree) (whole-tree-h tree)))
105 | 
106 | (define (box-width box)
107 |  (+ PADDING (ftglGetFontAdvance Font box)))
108 | 
109 | (define (box-height box)
110 |  (ftglGetFontLineHeight Font))
111 | 
112 | (define (box-maj-dim box)
113 |  (if VERTICAL (box-height box) (box-width box)))
114 | 
115 | (define (open? n tree) (set-member? (whole-tree-open tree) (node-laddr n)))
116 | (define closed? (negate open?))
117 | 
118 | (define get-color (lambda (a94 a95) (letrec ((v432 0.6180339887498949) (v354 (lambda (a359 a364) (letrec ((v358 a359)) (- v358 (letrec ((v363 a364)) (* v363 (truncate (/ v358 v363)))))))) (v206 (lambda (a222 a229 a230) (letrec ((v221 a222) (v223 (letrec ((v227 a230) (v228 a229)) (* v227 v228))) (v231 (* v223 (- 1 (abs (- (v354 (* v221 6) 2) 1)))))) (cond ((< v221 (/ 1 6)) (list v223 v231 0)) ((< v221 (/ 2 6)) (list v231 v223 0)) ((< v221 (/ 3 6)) (list 0 v223 v231)) ((< v221 (/ 4 6)) (list 0 v231 v223)) ((< v221 (/ 5 6)) (list v231 0 v223)) ((< v221 (/ 6 6)) (list v223 0 v231)))))) (v35 a95) (v26 a94) (v96 (cons (quote (0 0 0)) (map (curry * 255) (v206 0.15 1.0 1.0))))) (if (equal? (node-laddr v26) (whole-tree-selection v35)) v96 (letrec ((v110 (cons (quote (0 0 0)) (map (curry * 255) (v206 0.15 0.9 0.9))))) (if (equal? (car (node-data v26)) (car (node-data (utterance-node (whole-tree-selection-u v35))))) v110 (letrec ((v450 (lambda () (v354 (* (letrec ((v452 (lambda (a462) (letrec ((v461 a462)) (if (null? v461) 0 (last v461)))))) (v452 (node-laddr v26))) v432) 1))) (v85 (if (null? (node-laddr v26)) 0 (last (node-laddr v26)))) (v188 (cons (quote (255 255 255)) (quote (80 0 0)))) (v373 (cons (quote (255 255 255)) (map (curry * 255) (v206 (v450) 0.8 0.8)))) (v405 (cons (quote (255 255 255)) (map (curry * 255) (v206 (v450) 0.6 0.8))))) (if (odd? (length (node-laddr v26))) v373 v405))))))))
119 | 
120 | (define (maj-dim x y) (if VERTICAL y x))
121 | (define (min-dim x y) (if VERTICAL x y))
122 | 
123 | (define (center offset lenwhole lenpiece start width)
124 |  (let ((visible-width (- (min (+ offset lenwhole) (+ start width)) (max offset start))))
125 |   (if (< visible-width lenpiece)
126 |    (if (< offset start)
127 |     (- (+ offset lenwhole) lenpiece)
128 |     offset)
129 |    (+ (max offset start) (/ visible-width 2) (- (/ lenpiece 2))))))
130 | 
131 | (define (replace t1 t2s es)
132 |  (append (takef es (negate (curry equal? t1))) t2s (cdr (member t1 es))))
133 | 
134 | 


--------------------------------------------------------------------------------
/core/compiler.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "gnode.rkt")
 4 | 
 5 | (provide reify)
 6 | 
 7 | (define-syntax (with stx)
 8 |  (let* ((l (syntax->datum stx))
 9 |         (body (cadr l))
10 |         (defs (cddr l))
11 |         (lams (map (lambda (def) `(,(car def) (lambda ,(cadr def) ,@(cddr def)))) defs)))
12 |   (datum->syntax stx `(letrec ,lams ,@body))))
13 | 
14 | (define (id->sym id)
15 |  (string->symbol (format "v~a" id)))
16 | 
17 | (define (reify g id tracing?)
18 |  (calc-free-variables g)
19 |  (let reify-loop ((id id))
20 |   (let ((gn (hash-ref g id)))
21 |    (cond
22 |     ((variable-gnode? gn) (id->sym id))
23 |     ((terminal-gnode? gn) (gnode-name gn))
24 |     ((argument-gnode? gn) (id->sym id))
25 |     ((parent-gnode? gn)
26 |      (let* ((childs (parent-gnode-childs gn))
27 |             (childreifieds (map reify-loop childs))
28 |             (vars (topo-sort (parent-gnode-vars gn)))
29 |             (varsyms (map id->sym vars))
30 |             (ress (map (lambda (var)
31 |                         (let ((defined (variable-gnode-defined (hash-ref g var))))
32 |                          (if (function-gnode? (hash-ref g var))
33 |                           (let* ((args (function-gnode-args (hash-ref g var)))
34 |                                  (argsyms (map id->sym args)))
35 |                            `(lambda ,argsyms ,(reify-loop defined)))
36 |                           (reify-loop defined))))
37 |                        vars)))
38 |       (if (null? varsyms)
39 |        childreifieds
40 |        `(letrec ,(map list varsyms ress) ,childreifieds))))))))
41 | 
42 | (define (topo-sort ids)
43 |  (define traversed '())
44 |  (with
45 |   ((reverse (foldl topo '() ids)))
46 | 
47 |   (topo (id stack)
48 |    (if (or (member id traversed) (not (member id ids)))
49 |     stack
50 |     (begin
51 |      (set! traversed (cons id traversed))
52 |      (if (null? (hash-ref free-variables id))
53 |       (cons id stack)
54 |       (cons id (foldl topo stack (hash-ref free-variables id)))))))))
55 | 
56 | (define free-variables (hash))
57 | 
58 | (define (calc-free-variables g)
59 |  (with
60 |   ((for-each
61 |     update-free-variable-id
62 |     (hash-keys g)))
63 | 
64 |   (update-free-variable-id (id)
65 |    (let ((gn (hash-ref g id)))
66 |     (with
67 |      ((if (hash-has-key? free-variables id)
68 |        '()
69 |        (begin
70 |         (set! free-variables (hash-set free-variables id '()))
71 |         (set! free-variables (hash-set free-variables id (set->list (set-subtract (list->set (free-from-children)) (list->set (defined-here)))))))))
72 | 
73 |      (free-from-children ()
74 |       (remove-duplicates
75 |        (flatten
76 |         (append
77 |          (get-free-variables-from-children)
78 |          (get-new-free-variables)))))
79 | 
80 |      (get-free-variables-from-children ()
81 |       (map
82 |        (lambda (child) (update-free-variable-id child) (hash-ref free-variables child))
83 |        (cond
84 |         ((parent-gnode? gn) (parent-gnode-childs gn))
85 |         ((variable-gnode? gn) (list (variable-gnode-defined gn)))
86 |         (#t '()))))
87 | 
88 |      (get-new-free-variables ()
89 |       (if (or (variable-gnode? gn) (argument-gnode? gn))
90 |        (list id)
91 |        '()))
92 | 
93 |      (defined-here ()
94 |       (cond
95 |        ((parent-gnode? gn) (parent-gnode-vars gn))
96 |        ((function-gnode? gn) (function-gnode-args gn))
97 |        (#t '()))))))))
98 | 
99 | 


--------------------------------------------------------------------------------
/core/disp.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require (except-in racket/gui yield ->))
  4 | (require (only-in racket/gui (yield yield-gui) (-> ->-gui)))
  5 | (require sgl sgl/gl)
  6 | 
  7 | (require "common.rkt")
  8 | 
  9 | (provide (all-defined-out) my-canvas% box-width box-height box-maj-dim node-width node-height node-maj-dim VERTICAL display-on-screen add-to-screen Thecanvas Info Selected-tree utterance-parent utterance-node utterance-args node-data node-laddr whole-tree-selection-u whole-tree-selection set-whole-tree-selection! whole-tree-open set-whole-tree-open! whole-tree-utterance-tree add-key-evs key-evs update-childfuncs set-info push-mode pop-mode enter-insert-mode exit-insert-mode enter-scope-mode exit-scope-mode enter-argify-mode exit-argify-mode enter-search-mode exit-search-mode enter-paste-mode exit-paste-mode set-search-results Search-results show-search-tree scroll-search-results remove-search-tree paint-info semantic-go find-utterance-from-laddr-safe for-all-trees remove-tree open-u close-u cycle-v11n set-VAR1 set-VAR2 set-VAR3 VAR1 VAR2 VAR3 VAR1OFFSET VAR2OFFSET VAR3OFFSET VAR1MIN VAR2MIN VAR3MIN VAR1MAX VAR2MAX VAR3MAX generate-utterance-tree select Trees root->node)
 10 | 
 11 | (define WIDTH (* 1 1600))
 12 | (define HEIGHT 899)
 13 | 
 14 | (define VAR1 0)
 15 | (define VAR2 0)
 16 | (define VAR3 0)
 17 | (define VAR1OFFSET 1)
 18 | (define VAR2OFFSET 8)
 19 | (define VAR3OFFSET 8)
 20 | (define VAR1MIN 0)
 21 | (define VAR2MIN 0)
 22 | (define VAR3MIN 0)
 23 | (define VAR1MAX 50)
 24 | (define VAR2MAX 255)
 25 | (define VAR3MAX 255)
 26 | (define (set-VAR1 v) (set! VAR1 v))
 27 | (define (set-VAR2 v) (set! VAR2 v))
 28 | (define (set-VAR3 v) (set! VAR3 v))
 29 | 
 30 | (define COLORSCHEME 'alternate)
 31 | ;(define COLOR1 (cons '(255 255 255) '(0 0 96)))
 32 | ;(define COLOR2 (cons '(255 255 255) '(48 0 96)))
 33 | ;(define COLOR3 (cons '(255 255 255) '(0 48 96)))
 34 | ;(define COLOR4 (cons '(255 255 255) '(48 48 96)))
 35 | ;(define COLOR1 (cons '(255 255 255) '(96 0 0)))
 36 | ;(define COLOR2 (cons '(255 255 255) '(96 32 0)))
 37 | ;(define COLOR3 (cons '(255 255 255) '(96 72 0)))
 38 | ;(define COLOR4 (cons '(255 255 255) '(96 96 0)))
 39 | ;(define COLOR5 (cons '(255 255 255) '(80 0 0)))
 40 | ;(define COLOR6 (cons '(255 255 255) '(80 0 0)))
 41 | (define CODECOLOR1 (cons '(255 255 255) '(255 0 0)))
 42 | (define CODECOLOR2 (cons '(255 255 255) '(223 0 0)))
 43 | (define CODECOLOR3 (cons '(255 255 255) '(191 0 0)))
 44 | ;(define SELCOLOR (cons '(255 255 255) '(0 0 255)))
 45 | ;(define SEL2COLOR (cons '(255 255 255) '(112 0 112)))
 46 | (define INFOCOLOR (cons '(255 255 255) '(0 0 0)))
 47 | (define BGCOLOR "black")
 48 | (define INITIALCOLOR '(0 0 127))
 49 | (define COLORRANGES '(127 0 -127))
 50 | (define FGCOLOR '(255 255 255))
 51 | 
 52 | (define win (new frame% (label "vilisp") (min-width WIDTH) (min-height HEIGHT)))
 53 | 
 54 | (require (for-syntax racket/system))
 55 | (define-syntax (require-dir-v11ns syn)
 56 |  (let* ((dir (cadr (syntax->datum syn)))
 57 |         (phls (map (lambda (f) (string-append dir "/" f)) (filter (lambda (f) (regexp-match ".phl$" f)) (map path->string (directory-list dir))))))
 58 |   (for-each (lambda (phl) (system* "bin/phlisp" (string-append "-o " (regexp-replace ".phl$" phl ".rkt")) phl)) phls)
 59 |   (let* ((rkts (map (lambda (f) (string-append "../" dir "/" f)) (filter (lambda (f) (regexp-match ".rkt$" f)) (map path->string (directory-list dir)))))
 60 |          (rkts2 (map (lambda (rkt) `(prefix-in ,(string->symbol (string-append "v11n-" rkt ":")) ,rkt)) rkts))
 61 | 	 (regs (map (lambda (rkt) (string->symbol (string-append "v11n-" rkt ":visualization"))) rkts)))
 62 |    (displayln rkts)
 63 |    (datum->syntax syn `(begin
 64 | 			(require ,@rkts2)
 65 | 			(define v11ns (list ,@regs)))))))
 66 | 
 67 | (require-dir-v11ns "visualizations")
 68 | 
 69 | (define (cycle-v11n event)
 70 |  (set-whole-tree-v11n! Selected-tree
 71 |   (let* ((cur (whole-tree-v11n Selected-tree))
 72 |          (tail (member cur v11ns)))
 73 |    (if (or (null? tail) (null? (cdr tail)))
 74 |     (car v11ns)
 75 |     (cadr tail))))
 76 |  (generate-utterance-tree Selected-tree)
 77 |  (send Thecanvas on-paint))
 78 | 
 79 | (define Trees (list
 80 |                (apply whole-tree 
 81 |                       (let* ((dummy-n (node '(0 'dummy "dummy" () () () () ()) '() (delay '()) (lambda (_) "t")))
 82 |                              (dummy-utterance (cartesian-utterance dummy-n '() (cons '(0 0 0) '(0 0 0)) 0 0 0 0 0 0 )))
 83 |                        (list dummy-n (lambda (a) '()) dummy-utterance (set) '() 0 0 0 0 (list-ref v11ns 3) 0 0 1)))
 84 |                (apply whole-tree 
 85 |                       (let* ((dummy-n (node '(0 'dummy-bar "dummy bar" () () () () ()) '() (delay '()) (lambda (_) "r")))
 86 |                              (dummy-utterance (cartesian-utterance dummy-n '() (cons '(0 0 0) '(0 0 0)) 0 0 0 0 0 0 )))
 87 |                        (list dummy-n (lambda (a) '()) dummy-utterance (set) '() 800 30 (- WIDTH 600) 300 (cadddr v11ns) 0 0 1)))))
 88 | (set-selected-tree (cadr Trees))
 89 | (define (set-Trees ts) (set! Trees ts))
 90 | (define Bar-tree (cadr Trees))
 91 | 
 92 | (define (for-all-trees f)
 93 |  (for-each f (cdr Trees)))
 94 | 
 95 | (define key-evs (hash))
 96 | 
 97 | (define (add-key-evs args)
 98 |  (set! key-evs (apply hash-set* key-evs args)))
 99 | 
100 | (define (remove-tree tree)
101 |  (let ((next
102 |        (let ((r (member tree Trees)))
103 |         (if (null? (cdr r))
104 |          (if (null? (cddr Trees))
105 |           (cadr Trees)
106 |           (caddr Trees))
107 |          (cadr r)))))
108 |        (set! Trees (remove tree Trees))
109 |        (if (eq? Selected-tree tree)
110 |         (set-selected-tree next)
111 |         '())))
112 | 
113 | (define (semantic-go dir tree)
114 |  (let ((new-sel (cond
115 |                  ((eq? dir 'left)
116 |                   (let ((mem (takef (utterance-args (utterance-parent (whole-tree-selection-u tree) tree)) (negate (curry equal? (whole-tree-selection-u tree))))))
117 |                    (if (null? mem)
118 |                     #f
119 |                     (last mem))))
120 |                  ((eq? dir 'down)
121 |                   (car (utterance-args (whole-tree-selection-u tree))))
122 |                  ((eq? dir 'up)
123 |                   (utterance-parent (whole-tree-selection-u tree) tree))
124 |                  ((eq? dir 'right)
125 |                   (let ((mem (member (whole-tree-selection-u tree) (utterance-args (utterance-parent (whole-tree-selection-u tree) tree)))))
126 |                    (if (or (null? mem) (null? (cdr mem)))
127 |                     #f
128 |                     (cadr mem)))))))
129 |   (select (or new-sel (whole-tree-selection-u tree)) tree)
130 |   (generate-utterance-tree tree)
131 |   (send Thecanvas on-paint)))
132 | 
133 | (define mouse-evs
134 |  (hash
135 |   'dragging (lambda (event)
136 |              (define-mouse-handler (rel-x rel-y)
137 |               (cond
138 |                ((send event get-left-down)
139 |                 (set-whole-tree-offset-x! Chosen-tree (+ (whole-tree-offset-x Chosen-tree) (/ (+ (- (car Mouse-pos)) rel-x) (whole-tree-zoom tree))))
140 |                 (set-whole-tree-offset-y! Chosen-tree (+ (whole-tree-offset-y Chosen-tree) (/ (+ (- (cdr Mouse-pos)) rel-y) (whole-tree-zoom tree))))
141 |                 (set! Mouse-pos (cons rel-x rel-y))
142 |                 (send Thecanvas on-paint)))))
143 |   'motion (lambda (event)
144 |            (define-mouse-handler (clicked)
145 |             (let ((text (format "~s" (node-data (utterance-node clicked)))))
146 |              (if (equal? Info text)
147 |               '()
148 |               (begin
149 |                (set! Info text)
150 |                (paint-info Info #t))))))
151 |   'left-down (lambda (event)
152 |               (define-mouse-handler (rel-x rel-y)
153 |                (set! Chosen-tree tree)
154 |                (set! Mouse-pos (cons rel-x rel-y))))
155 |   'left-up (lambda (event)
156 |             (define-mouse-handler (clicked)
157 |              (select clicked tree)
158 |              (generate-utterance-tree tree)
159 |              (send Thecanvas on-paint)))
160 |   'middle-down (lambda (event)
161 |                 (define-mouse-handler (clicked)
162 |                  (select clicked tree)
163 |                  (close-u (whole-tree-selection-u tree) (send event get-control-down) Selected-tree)
164 |                  (send Thecanvas on-paint)))
165 |   'right-down (lambda (event)
166 |                (define-mouse-handler (clicked)
167 |                 (select clicked tree)
168 |                 (open-u (whole-tree-selection-u tree) (send event get-control-down) Selected-tree)
169 |                 (send Thecanvas on-paint)))
170 | ))
171 | 
172 | (define (open-u u deep? tree)
173 |  (set-whole-tree-open! tree (set-union (whole-tree-open tree)
174 |                              (list->set
175 |                               (map
176 |                                node-laddr
177 |                                (if deep?
178 |                                 (flatten (cons (utterance-node u) (map (lambda (a) (node-deep-args a (compose (curryr member '(scoped var)) cadr node-data))) (node-args (utterance-node u)))))
179 |                                 (letrec
180 |                                  ((lam (lambda (l)
181 |                                         (if (or (null? l) (ormap (lambda (x) (closed? x tree)) l))
182 |                                          l
183 |                                          (lam (flatten (map node-args l)))))))
184 |                                  (lam (list (utterance-node u)))))))))
185 |   (generate-utterance-tree tree))
186 | 
187 | (define (close-u u deep? tree)
188 |  (set-whole-tree-open! tree (set-subtract (whole-tree-open tree)
189 |                              (list->set
190 |                               (map
191 |                                node-laddr
192 |                                (if deep?
193 |                                 (let ((remnant (if (closed? (utterance-node u) tree) (utterance-parent u tree) u)))
194 |                                  (select remnant tree)
195 |                                  (flatten (node-deep-args (utterance-node remnant) (curryr closed? tree))))
196 |                                 (if (closed? (utterance-node u) tree)
197 |                                  (begin
198 |                                   (select (utterance-parent u tree) tree)
199 |                                   (flatten (node-deep-args (utterance-node (utterance-parent u tree)) (curryr closed? tree))))
200 |                                  (letrec
201 |                                   ((lam (lambda (l)
202 |                                          (if (andmap
203 |                                               (lambda (x) (or (closed? x tree) (null? (node-args x))))
204 |                                               (flatten (map node-args l)))
205 |                                           (append l (flatten (map node-args l)))
206 |                                           (lam (flatten (map node-args l)))))))
207 |                                   (lam (list (utterance-node u))))))))))
208 |  (generate-utterance-tree tree))
209 | 
210 | (define (node-deep-args n pred)
211 |  (if (pred n) '() (cons n (map (lambda (a) (node-deep-args a pred)) (node-args n)))))
212 | 
213 | (define my-canvas%
214 |  (with
215 |   ((class* canvas% ()
216 |    (inherit with-gl-context swap-gl-buffers)
217 |  
218 |    (define/override (on-paint)
219 |     (with-gl-context
220 |       (lambda ()
221 |        (gl-clear-color 0.0 0.0 0.0 0.0)
222 |        (gl-clear 'color-buffer-bit)
223 | 
224 |        (paint-info Info #f)
225 |        (paint-bar (whole-tree-selection-u Selected-tree))
226 |  
227 |        (gl-enable 'scissor-test)
228 |  
229 |        (for-each (lambda (tree) ((v11n-paint-tree (whole-tree-v11n tree)) tree)) Trees)
230 |  
231 |        (gl-disable 'scissor-test)
232 |        (swap-gl-buffers))))
233 |   
234 |    (define/override (on-event event)
235 |     (if (send event dragging?)
236 |       ((hash-ref mouse-evs 'dragging) event)
237 |       (if (hash-has-key? mouse-evs (send event get-event-type))
238 |         ((hash-ref mouse-evs (send event get-event-type)) event)
239 |         '())))
240 | 
241 |    (define/override (on-char event)
242 |     (if (null? Mode)
243 |      (when (hash-has-key? key-evs (send event get-key-code))
244 |       ((hash-ref key-evs (send event get-key-code)) event))
245 |      ((hash-ref key-evs (car Mode)) event)))
246 | 
247 |    (super-instantiate () (style '(gl)))
248 | 
249 |    (with-gl-context
250 |     (lambda ()
251 |      (initialize-font)))))))
252 | 
253 | (define Mode '())
254 | 
255 | (define (push-mode m)
256 |  (set! Mode (cons m Mode)))
257 | 
258 | (define (pop-mode)
259 |  (let ((res (car Mode)))
260 |   (set! Mode (cdr Mode))
261 |   res))
262 | 
263 | ;(define INSERTMODE #f)
264 | 
265 | ;(define (enter-insert-mode) (set! INSERTMODE #t) (set! Search-tree (add-to-screen (list 0 'list '() '() '() '() '() '()) (whole-tree-childfunc Selected-tree))))
266 | (define (enter-insert-mode) (push-mode 'insert) (set! Search-tree (add-to-screen (list 0 'list '() '() '() '() '() '()) (whole-tree-childfunc Selected-tree))))
267 | 
268 | ;(define (exit-insert-mode) (set! INSERTMODE #f))
269 | (define exit-insert-mode pop-mode)
270 | 
271 | ;(define SCOPEMODE #f)
272 | 
273 | (define (enter-scope-mode) (push-mode 'scope))
274 | 
275 | (define exit-scope-mode pop-mode)
276 | 
277 | (define (enter-argify-mode) (push-mode 'argify))
278 | 
279 | (define exit-argify-mode pop-mode)
280 | 
281 | (define (enter-search-mode) (push-mode 'search) (set! Search-tree (add-to-screen (list 0 'list '() '() '() '() '() '()) (whole-tree-childfunc Selected-tree))))
282 | 
283 | (define exit-search-mode pop-mode)
284 | 
285 | (define (enter-paste-mode) (push-mode 'paste))
286 | 
287 | (define exit-paste-mode pop-mode)
288 | 
289 | (define (paint-bar u)
290 |  (with
291 |   ((gl-enable 'scissor-test)
292 |    (apply gl-scissor (rel->gl Bar-dim))
293 |    (gl-viewport 0 30 WIDTH 300)
294 |    (gl-matrix-mode 'projection)
295 |    (gl-load-identity)
296 |    (gl-ortho 0 WIDTH 30 330 -1.0 1.0)
297 |    (gl-clear 'color-buffer-bit)
298 |    (paint-u)
299 |    (gl-disable 'scissor-test))
300 | 
301 |   (paint-u ()
302 |    (gl-color (/ (car (car INFOCOLOR)) 255) (/ (cadr (car INFOCOLOR)) 255) (/ (caddr (car INFOCOLOR)) 255))
303 |    (paint paint-name 0 310)
304 |    (paint paint-id 0 290)
305 |    (paint paint-type 0 270)
306 |    (paint paint-open 0 250)
307 |    (paint paint-laddr 0 230)
308 |    (paint-utterance-data 0 210)
309 |    (paint paint-lexical-parent 0 110)
310 |    (paint paint-free-variables 0 90)
311 |    (paint paint-bound-variables 0 70)
312 |    (paint paint-open-set 0 50)
313 |    (paint paint-vars 0 30)
314 |    (paint-neighborhood)
315 |    (paint-runtime-vals)
316 |    (set-tree)
317 |    (paint-search-results))
318 | 
319 |   (paint (func x y)
320 |    (gl-push-matrix)
321 |    (gl-translate x y 0)
322 |    (func)
323 |    (gl-pop-matrix))
324 | 
325 |   (paint-name ()
326 |    (ftglRenderFont Font ((node-text-func (utterance-node u)) (utterance-node u)) 65535))
327 | 
328 |   (paint-id ()
329 |    (ftglRenderFont Font (format "id:  ~a" (car (node-data (utterance-node u)))) 65535))
330 | 
331 |   (paint-type ()
332 |    (ftglRenderFont Font (format "type:  ~a" (cadr (node-data (utterance-node u)))) 65535))
333 | 
334 |   (paint-open ()
335 |    (ftglRenderFont Font (if (open? (utterance-node u) Selected-tree) "open" "closed") 65535))
336 | 
337 |   (paint-laddr ()
338 |    (ftglRenderFont Font (format "laddr:  ~a" (node-laddr (utterance-node u))) 65535))
339 | 
340 |   (paint-utterance-data (x y)
341 |    (gl-push-matrix)
342 |    (gl-translate x y 0)
343 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "x:  ~a" (cartesian-utterance-x u)) 65535))
344 |    (gl-translate 100 0 0)
345 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "y:  ~a" (cartesian-utterance-y u)) 65535))
346 |    (gl-translate -100 -20 0)
347 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "w:  ~a" (cartesian-utterance-w u)) 65535))
348 |    (gl-translate 100 0 0)
349 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "h:  ~a" (cartesian-utterance-h u)) 65535))
350 |    (gl-translate -100 -20 0)
351 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "text-w:  ~a" (cartesian-utterance-text-w u)) 65535))
352 |    (gl-translate 100 0 0)
353 |    (when (cartesian-utterance? u) (ftglRenderFont Font (format "text-h:  ~a" (cartesian-utterance-text-h u)) 65535))
354 |    (gl-translate -100 -20 0)
355 |    (ftglRenderFont Font (format "color:  ~a" (utterance-clr u)) 65535)
356 |    (gl-translate 0 -20 0)
357 |    (ftglRenderFont Font (format "children:  ~a" (map (lambda (u) ((node-text-func (utterance-node u)) (utterance-node u))) (utterance-args u))) 65535)
358 |    (gl-pop-matrix))
359 | 
360 |   (paint-lexical-parent ()
361 |    (ftglRenderFont Font (format "lexcial parent:  ~a" (cadddr (cdddr (node-data (utterance-node u))))) 65535))
362 | 
363 |   (paint-free-variables ()
364 |    (ftglRenderFont Font (format "free variables:  ~a" (cadddr (cdr (node-data (utterance-node u))))) 65535))
365 | 
366 |   (paint-bound-variables ()
367 |    (ftglRenderFont Font (format "bound variables:  ~a" (cadddr (cddr (node-data (utterance-node u))))) 65535))
368 | 
369 |   (paint-open-set ()
370 |    (ftglRenderFont Font (format "open set:  ~a" (whole-tree-open Selected-tree)) 65535))
371 | 
372 |   (paint-vars ()
373 |    (ftglRenderFont Font (format "VAR1:  ~a VAR2:  ~a VAR3:  ~a" VAR1 VAR2 VAR3) 65535))
374 | 
375 |   (paint-neighborhood ()
376 |    (gl-push-matrix)
377 |    (gl-translate 300 310 0)
378 |    (map paint-triple (cadddr (node-data (utterance-node u))) (build-list (length (cadddr (node-data (utterance-node u)))) identity))
379 |    (gl-pop-matrix))
380 | 
381 |   (paint-triple (t n)
382 |    (gl-translate 0 -20 0)
383 |    (ftglRenderFont Font (format "~a" t) 65535))
384 | 
385 |   (paint-runtime-vals ()
386 |    (gl-push-matrix)
387 |    (gl-translate 600 313 0)
388 |    (let ((width (apply max (map (lambda (u) (box-width (format "~a" ((node-text-func (utterance-node u)) (utterance-node u))))) (cons u (utterance-args u))))))
389 |     (for-each
390 |      (lambda (u n)
391 |       (let ((text (format "~a" ((node-text-func (utterance-node u)) (utterance-node u)))))
392 |        (draw-rectangle '(96 96 0) (if (zero? n) 600 610) (+ -330 (* 20 n)) (if (zero? n) (+ width 10) width) 20)
393 |        (gl-color 1 1 1)
394 |        (gl-translate 0 -20 0)
395 |        (ftglRenderFont Font text 65535)))
396 |      (cons u (utterance-args u))
397 |      (build-list (+ 1 (length (utterance-args u))) identity))
398 |     (gl-pop-matrix)
399 |     (gl-push-matrix)
400 |     (gl-translate (+ 610 width) 0 0)
401 |     (let ((r-vs (list-ref (node-data (utterance-node u)) 7)))
402 |      (if (null? r-vs)
403 |       '()
404 |       (for-each
405 |        (lambda (r-v n)
406 |         (gl-translate -40 0 0)
407 |         (ftglRenderFont Font (format "~a" (cadr r-v)) 65535)
408 | ;        (gl-translate 0 -20 0)
409 |         (for-each
410 |          (lambda (node-id val)
411 |           (for-each
412 |            (lambda (i-u m)
413 |             (if (eq? (car (node-data (utterance-node i-u))) node-id)
414 |              (begin
415 |               (gl-raster-pos 0 -20)
416 |               (ftglRenderFont Font (format "~a" val) 65535))
417 |              '()))
418 |            (utterance-args u)
419 |            (build-list (length (utterance-args u)) identity)))
420 |          (list-ref r-v 3)
421 |          (list-ref r-v 4)))
422 |        r-vs
423 |        (build-list (length r-vs) identity))))))
424 | 
425 |   (set-tree ()
426 |    (set-whole-tree-childfunc! Bar-tree (whole-tree-childfunc Selected-tree))
427 |    (set-whole-tree-n-tree! Bar-tree (root->node (node-data (utterance-node u)) (whole-tree-childfunc Bar-tree) '()))
428 |    (set-whole-tree-open! Bar-tree (set))
429 |    (set-whole-tree-selection! Bar-tree '())
430 |    (set-whole-tree-offset-x! Bar-tree 0)
431 |    (set-whole-tree-offset-y! Bar-tree 0)
432 |    (set-whole-tree-zoom! Bar-tree 1)
433 |    (generate-utterance-tree Bar-tree)
434 |    (open-u (whole-tree-utterance-tree Bar-tree) #t Bar-tree))
435 | 
436 |   (paint-search-results ()
437 |    (gl-push-matrix)
438 |    (gl-translate (- WIDTH 300) 310 0)
439 |    (map paint-triple Search-results (build-list (length Search-results) identity))
440 |    (gl-pop-matrix))))
441 | 
442 | (define Search-results '())
443 | (define Search-tree '())
444 | 
445 | (define (set-search-results res) (set! Search-results res))
446 | 
447 | (define (scroll-search-results) (if (null? Search-results) '() (set! Search-results (append (cdr Search-results) (list (car Search-results))))))
448 | 
449 | (define (show-search-tree get-rep)
450 |  (if (null? Search-results)
451 |   '()
452 |   (begin
453 |    (set-whole-tree-childfunc! Search-tree (whole-tree-childfunc Selected-tree))
454 |    (set-whole-tree-n-tree! Search-tree (root->node (get-rep (caar Search-results)) (whole-tree-childfunc Search-tree) '()))
455 |    (set-whole-tree-open! Search-tree (set))
456 |    (set-whole-tree-selection! Search-tree '())
457 |    (set-whole-tree-offset-x! Search-tree 0)
458 |    (set-whole-tree-offset-y! Search-tree 0)
459 |    (set-whole-tree-zoom! Search-tree 1)
460 |    (generate-utterance-tree Search-tree)
461 |    (open-u (whole-tree-utterance-tree Search-tree) #t Search-tree))))
462 | 
463 | (define (remove-search-tree)
464 |  (remove-tree Search-tree))
465 | 
466 | (define (set-info text)
467 |  (set! Info text))
468 | 
469 | (define (paint-info text swap)
470 |  (gl-enable 'scissor-test)
471 |  (apply gl-scissor (rel->gl Info-dim))
472 |  (gl-viewport 0 0 WIDTH 30)
473 |  (gl-matrix-mode 'projection)
474 |  (gl-load-identity)
475 |  (gl-ortho 0 WIDTH 0 30 -1.0 1.0)
476 |  (gl-clear 'color-buffer-bit)
477 |  (gl-color (/ (car (car INFOCOLOR)) 255) (/ (cadr (car INFOCOLOR)) 255) (/ (caddr (car INFOCOLOR)) 255))
478 |  (gl-raster-pos 0 10)
479 |  (gl-push-matrix)
480 |  (gl-translate 0 5 0)
481 |  (ftglRenderFont Font (substring text 0 (min (string-length text) 200)) 65535)
482 |  (gl-pop-matrix)
483 |  (gl-disable 'scissor-test)
484 |  (if swap
485 |   (send Thecanvas on-paint)
486 |   '()))
487 | 
488 | (define (in? dim x y)
489 |  (and (> x (car dim)) (> y (cadr dim)) (< x (+ (car dim) (caddr dim))) (< y (+ (cadr dim) (cadddr dim)))))
490 | 
491 | ; XXX reimplement in terms of addresses?
492 | (define (utterance-parent u tree)
493 |  (let loop ((root (whole-tree-utterance-tree tree)))
494 |   (if (member u (utterance-args root))
495 |    root
496 |    (ormap loop (utterance-args root)))))
497 |  
498 | (define (select u tree)
499 |  (set-selected-tree tree)
500 |  (set-whole-tree-selection! tree (node-laddr (utterance-node u)))
501 |  )
502 | ; (let ((x (+ (whole-tree-offset-x tree) (utterance-x u)))
503 | ;       (y (+ (whole-tree-offset-y tree) (utterance-y u)))
504 | ;       (w (utterance-w u))
505 | ;       (h (utterance-h u)))
506 | ;  (if
507 | ;   (or
508 | ;    (and (negative? (+ x w)) (not VERTICAL))
509 | ;    (> x (/ (whole-tree-w tree) (whole-tree-zoom tree))))
510 | ;   (let ((c (+ (utterance-x u) (/ w 2))))
511 | ;    (set-whole-tree-offset-x! tree (- (+ c (- (/ (whole-tree-w tree) (whole-tree-zoom tree) 2))))))
512 | ;   '())
513 | ;  (if
514 | ;   (or
515 | ;    (and (negative? (+ y h)) VERTICAL)
516 | ;    (> y (/ (whole-tree-h tree) (whole-tree-zoom tree))))
517 | ;   (let ((c (+ (utterance-y u) (/ h 2))))
518 | ;    (set-whole-tree-offset-y! tree (- (+ c (- (/ (whole-tree-h tree) (whole-tree-zoom tree) 2))))))
519 | ;   '())))
520 | 
521 | (define Info-dim (list 0 (- HEIGHT 30) WIDTH 30))
522 | (define Bar-dim (list 0 (- HEIGHT 330) WIDTH 300))
523 | 
524 | ;(define Font #f)
525 | 
526 | (define (initialize-font)
527 |  (set-font (ftglCreateTextureFont "/home/philip/oldhome/olddesktop/vilisp/VeraMono.ttf"))
528 |  (ftglSetFontFaceSize Font 12 72))
529 | 
530 | (define Mouse-pos (cons -1 -1))
531 | (define Info "test")
532 | (define Thecanvas (new my-canvas% (parent win)))
533 | 
534 | (define (rel->gl l)
535 |  (list (car l) (- HEIGHT (+ (cadddr l) (cadr l))) (caddr l) (cadddr l)))
536 | 
537 | (define (generate-utterance-tree tree)
538 |  (set-whole-tree-utterance-tree! tree ((v11n-node->v11n-utterance (whole-tree-v11n tree)) (whole-tree-n-tree tree) tree)))
539 | ; (set-whole-tree-utterance-tree! tree ((v11n-node->v11n-utterance (whole-tree-v11n tree)) (whole-tree-n-tree tree) (utterance-x (whole-tree-utterance-tree tree)) (utterance-y (whole-tree-utterance-tree tree)) (if VERTICAL (node-width (whole-tree-n-tree tree) tree) 0) 0 1 tree)))
540 | 
541 | (define (find-utterance-from-laddr tree laddr)
542 |  (if (null? laddr)
543 |   tree
544 |   (find-utterance-from-laddr (list-ref (utterance-args tree) (car laddr)) (cdr laddr))))
545 | 
546 | (define (update-childfuncs childfunc)
547 |  (map (curryr set-whole-tree-childfunc! childfunc) (cdr Trees))
548 |  (map (lambda (t) (set-whole-tree-n-tree! t (root->node (node-data (whole-tree-n-tree t)) childfunc (node-laddr (whole-tree-n-tree t))))) (cdr Trees))
549 |  (map generate-utterance-tree (cdr Trees))
550 |  (send Thecanvas on-paint))
551 | 
552 | (define (add-to-screen root childfunc)
553 |  (let ((tree (display-on-screen 0 0 (/ WIDTH 2) 0 root childfunc)))
554 |   (normalize-trees)
555 |   tree))
556 | 
557 | (define (normalize-trees)
558 |  (let* ((num (length (cdddr Trees)))
559 |         (h (round (/ (- HEIGHT 330) num))))
560 |   (for-each
561 |    (lambda (tree n)
562 |     (set-whole-tree-x! tree (/ WIDTH 2))
563 |     (set-whole-tree-y! tree (+ 330 (* (- (+ -1 num) n) h)))
564 |     (set-whole-tree-w! tree (/ WIDTH 2))
565 |     (set-whole-tree-h! tree h))
566 |    (cdddr Trees)
567 |    (build-list num identity))))
568 | 
569 | (define (display-on-screen x y w h root childfunc)
570 |  (let ((tree
571 |   (let* ((n (root->node root childfunc '()))
572 |          (dummy-utterance (cartesian-utterance n '() (cons '(0 0 0) '(0 0 0)) 0 0 0 0 0 0 )))
573 |    (whole-tree
574 |     n
575 |     childfunc
576 |     dummy-utterance
577 |     (set)
578 |     '()
579 |     x
580 |     y
581 |     w
582 |     h
583 |     (list-ref v11ns 3)
584 |     0
585 |     0
586 |     1))))
587 |  (set-whole-tree-utterance-tree! tree ((v11n-node->v11n-utterance (list-ref v11ns 3)) (whole-tree-n-tree tree) tree))
588 |  (set-whole-tree-selection! tree '())
589 |  (set! Trees (append Trees (list tree)))
590 |  tree))
591 | 
592 | (define (root->node data childlist laddr)
593 |  (node data laddr
594 |   (delay
595 |    (let ((children (childlist data)))
596 |     (map
597 |      (lambda (arg n) (root->node arg childlist (append laddr (list n))))
598 |      children
599 |      (build-list (length children) values))))
600 |   (lambda (n) (format "~s" (caddr (node-data n))))))
601 | 
602 | (define Chosen-tree '())
603 | (define-for-syntax mouse-handler-hash (hash
604 | 			'clicked '((v11n-find-utterance (whole-tree-v11n tree))
605 |                                    (whole-tree-utterance-tree tree)
606 |                                    (+
607 |                                     (- (whole-tree-x tree))
608 |                                     (- (/ (send event get-x) (whole-tree-zoom tree)) (whole-tree-offset-x tree)))
609 |                                    (+
610 |                                     (+ (- HEIGHT) (whole-tree-h tree) (whole-tree-y tree))
611 |                                     (- (/ (send event get-y) (whole-tree-zoom tree)) (whole-tree-offset-y tree)))
612 |                                    tree)
613 | 			'abs-x '(- (/ (send event get-x) (whole-tree-zoom tree)) (whole-tree-offset-x tree))
614 | 			'abs-y '(- (/ (send event get-y) (whole-tree-zoom tree)) (whole-tree-offset-y tree))
615 | 			'rel-x '(send event get-x)
616 | 			'rel-y '(send event get-y)))
617 | 
618 | (define-syntax (define-mouse-handler stx)
619 |  (let* ((args (syntax->datum stx))
620 | 	(reqs (cadr args))
621 | 	(code (cddr args))
622 | 	(vals (map (lambda (req) (list req (hash-ref mouse-handler-hash req))) reqs)))
623 |   (datum->syntax stx `(let ((tree (let ((x (send event get-x)) (y (send event get-y))) (or (findf (compose (curryr in? x (- HEIGHT y)) whole-tree-dim) Trees) Selected-tree))))
624 |                        (let ,vals ,@code)))))
625 | 
626 | 
627 | (send win show #t)
628 | 


--------------------------------------------------------------------------------
/core/extractdata.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "gnode.rkt" "graph.rkt" "disp.rkt" "compiler.rkt" "common.rkt")
  4 | (require racket/set)
  5 | 
  6 | (provide Thecanvas Info (all-defined-out) update-childfuncs for-all-trees semantic-go key-evs)
  7 | 
  8 | (define GRFILE "")
  9 | 
 10 | (define NEWCODE #f)
 11 | 
 12 | (define X 0)
 13 | (define Y 0)
 14 | 
 15 | (define Next-id 100)
 16 | 
 17 | ;(define-syntax (with stx)
 18 | ; (let* ((l (syntax->datum stx))
 19 | ;        (body (cadr l))
 20 | ;        (defs (cddr l))
 21 | ;        (lams (map (lambda (def) `(,(car def) (lambda ,(cadr def) ,@(cddr def)))) defs)))
 22 | ;  (datum->syntax stx `(letrec ,lams ,@body))))
 23 | 
 24 | (define G '())
 25 | (define (set-G g) (set! G g))
 26 | 
 27 | (define (read-file filename)
 28 |  (set! G (call-with-input-file filename (lambda (f) (read f)))))
 29 | 
 30 | (define INSERTTEXT "")
 31 | (define LINK1 '())
 32 | (define LINK1PARENT '())
 33 | (define LINK1ADDR '())
 34 | 
 35 | (define runtime-vals (hash))
 36 | (define (set-runtime-vals vals) (set! runtime-vals vals))
 37 | 
 38 | (define (set-Next-id id) (set! Next-id id))
 39 | 
 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 41 | ;;;                                                                     Graph Changers                                                                      ;;;
 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 43 | 
 44 | (define (updater
 45 |          #:undoer (undoer undo-push)
 46 |          #:graph-changer (graph-changer values)
 47 |          #:open-updater (open-updater values)
 48 |          #:data-updater (data-updater update-data)
 49 |          #:childfuncs-updater (childfuncs-updater (lambda () (update-childfuncs child-fun)))
 50 |          #:selection-updater (selection-updater values))
 51 |  (undoer)
 52 |  (graph-changer)
 53 |  (open-updater)
 54 |  (data-updater)
 55 |  (childfuncs-updater)
 56 |  (selection-updater))
 57 | 
 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 59 | ;;;                                                                   Laddr Adjustments                                                                     ;;;
 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 61 | 
 62 | (define (adjust-laddr id parent-id pos u laddr)
 63 |  (if (null? laddr)
 64 |   '()
 65 |   (if (and (> (car laddr) pos)
 66 |            (eq? parent-id (car (node-data (utterance-node u)))))
 67 |    (cons (+ 1 (car laddr)) (adjust-laddr id parent-id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr)))
 68 |    (cons (car laddr) (adjust-laddr id parent-id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr))))))
 69 | 
 70 | (define (adjust-laddr-interlocute id pos tree)
 71 |  (with
 72 |   ((set-union
 73 |     (adjust-currently-open)
 74 |     (add-in-all-nodes-with-id)))
 75 | 
 76 |   (adjust-currently-open ()
 77 |    (list->set (set-map (whole-tree-open tree) (curry adjust-laddr-interlocutor id pos (whole-tree-utterance-tree tree)))))
 78 | 
 79 |   (add-in-all-nodes-with-id ()
 80 |    (set-remove (list->set (set-map (whole-tree-open tree) (lambda (laddr) (if (eq? id (car (node-data (utterance-node (find-utterance-from-laddr-safe (whole-tree-utterance-tree tree) laddr))))) laddr '_)))) '_))))
 81 | 
 82 | (define (adjust-laddr-interlocutor id pos u laddr)
 83 |  (if (null? laddr)
 84 |   '()
 85 |   (if (and (= (car laddr) pos) (eq? id (car (node-data (utterance-node (list-ref (utterance-args u) pos))))))
 86 |    (cons (car laddr) (cons 0 (adjust-laddr-interlocutor id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr))))
 87 |    (cons (car laddr) (adjust-laddr-interlocutor id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr))))))
 88 | 
 89 | (define (adjust-laddr-del id pos u laddr)
 90 |  (if (null? laddr)
 91 |   '()
 92 |   (if (and (>= (car laddr) pos) (eq? id (car (node-data (utterance-node (list-ref (utterance-args u) pos))))))
 93 |    (cons (+ -1 (car laddr)) (adjust-laddr-del id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr)))
 94 |    (cons (car laddr) (adjust-laddr-del id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr))))))
 95 | 
 96 | (define (remove-laddr-del-aux id pos u laddr)
 97 |  (remove-laddr-del id pos u laddr laddr))
 98 | 
 99 | (define (remove-laddr-del id pos u laddr whole-laddr)
100 |  (if (null? laddr)
101 |   '()
102 |   (begin
103 |   (if (and (= (car laddr) pos) (eq? id (car (node-data (utterance-node (list-ref (utterance-args u) pos))))))
104 |    whole-laddr
105 |    (remove-laddr-del id pos (list-ref (utterance-args u) (car laddr)) (cdr laddr) whole-laddr)))))
106 | 
107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
108 | ;;;                                                                     Miscellaneous                                                                       ;;;
109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110 | 
111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 | ;;;                             Utility Functions                           ;;;
113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114 | 
115 | (define (selected-id tree)
116 |  (car (node-data (utterance-node (whole-tree-selection-u tree)))))
117 | 
118 | (define (selected-parent-id tree)
119 |  (car (node-data (utterance-node (utterance-parent (whole-tree-selection-u tree) tree)))))
120 | 
121 | (define (common-ancestor id1 id2)
122 |  (with
123 |   ((find-first-overlap (ancestors id1) (ancestors id2)))
124 | 
125 |   (ancestors (id)
126 |    (let loop ((cur 0) (l '()))
127 |     (if (= id cur)
128 |      (cons cur l)
129 |      (ormap
130 |       (curryr loop (cons cur l))
131 |       (lexical-children id)))))
132 | 
133 |   (find-first-overlap (l1 l2)
134 |    (if (null? l1)
135 |     #f
136 |     (if (member (car l1) l2)
137 |      (car l1)
138 |      (find-first-overlap (cdr l1) l2))))))
139 | 
140 | (define (graph-ids g) (hash-keys G))
141 | 
142 | (define (lexical-children id)
143 |  (let ((gn (hash-ref G id)))
144 |   (cond
145 |    ((parent-gnode? gn) (append (parent-gnode-childs gn) (map (compose variable-gnode-defined (curry hash-ref G)) (parent-gnode-vars gn))))
146 |    (#t '()))))
147 | 
148 | (define (graph->file g)
149 |  (let ((g (hash-set g 'next-id Next-id)))
150 |   (call-with-output-file GRFILE #:exists 'truncate (lambda (f) (write g f)))))
151 | 
152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153 | ;;;                                 Undo/Redo                               ;;;
154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
155 | 
156 | (struct state (graph trees selected-tree))
157 | 
158 | (define UNDOSTACK '())
159 | (define REDOSTACK '())
160 | (define (set-UNDOSTACK stack) (set! UNDOSTACK stack))
161 | (define (set-REDOSTACK stack) (set! REDOSTACK stack))
162 | 
163 | (define (copy-trees)
164 |  (map
165 |   (lambda (tree) (struct-copy whole-tree tree))
166 |   Trees))
167 | 
168 | (define (get-selected-tree-index)
169 |  (- (length (dropf-right Trees (negate (curry eq? Selected-tree)))) 1))
170 | 
171 | (define (undo-push)
172 |  (set! REDOSTACK '())
173 |  (set! UNDOSTACK (cons (state G (copy-trees) (get-selected-tree-index)) UNDOSTACK)))
174 | ; (set! UNDOSTACK (cons (list G (whole-tree-open Selected-tree) (whole-tree-selection Selected-tree)) UNDOSTACK)))
175 | 
176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
177 | ;;;                                 Clipboard                               ;;;
178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
179 | 
180 | (define Clipboard #f)
181 | 
182 | (define (push-clipboard id)
183 |  (set! Clipboard id))
184 | 
185 | (define (pop-clipboard) Clipboard)
186 | 
187 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 | ;;;                                                                  Child-fun and Related                                                                  ;;;
189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
190 |  
191 | (define (child-fun a)
192 | ; (displayln a)
193 |  (map
194 |   get-rep
195 |   (let ((gn (hash-ref G (car a))))
196 |    (cond
197 |     ((parent-gnode? gn) (parent-gnode-childs gn))
198 |     ((function-gnode? gn) (append (list (variable-gnode-defined gn)) (function-gnode-args gn)))
199 |     ((variable-gnode? gn) (list (variable-gnode-defined gn)))
200 |     (#t '())))))
201 | 
202 | (define (get-rep id)
203 |  (with
204 |   ((append (list id) (get-written id) (list (nei) (get-free-variables) (get-bound-variables) (lex-chi) (runtime-values))))
205 | 
206 |   (nei ()
207 |    '(to be implemented))
208 | 
209 |   (get-free-variables ()
210 |    (hash-ref free-variables id '()))
211 | 
212 |   (get-bound-variables ()
213 |    (hash-ref bound-variables id '()))
214 | 
215 |   (lex-chi ()
216 |    (lexical-children id))
217 |   
218 |   (runtime-values ()
219 |    (let* ((reses (map
220 |                   (curry triple-end)
221 |                   (graph-neighborhood-edge-forward runtime-vals id 'has-res)))
222 |           (vals (map
223 |                  (compose (curry map triple-end) (curryr (curry graph-neighborhood-edge-forward runtime-vals) 'has-val))
224 |                  reses)))
225 |     (map
226 |      (lambda (res val)
227 |       (let* ((root-reses (map triple-end (graph-neighborhood-edge-forward runtime-vals res 'has-roots)))
228 |              (root-nodes (map
229 |                           (compose (curry triple-start) safe-car (curryr (curry graph-neighborhood-edge-backward runtime-vals) 'has-res))
230 |                           root-reses))
231 |              (root-vals (map
232 |                          (compose (curry triple-end) safe-car (curryr (curry graph-neighborhood-edge-forward runtime-vals) 'has-val))
233 |                          root-reses)))
234 |        (cons res (cons val (cons root-reses (cons root-nodes (cons root-vals '())))))))
235 |       reses
236 |       vals)))))
237 | 
238 | (define (safe-car l)
239 |  (if (null? l)
240 |   '()
241 |   (car l)))
242 | 
243 | (define (get-written id)
244 |  (let* ((gn (hash-ref G id)))
245 |   (cond
246 |    ((function-gnode? gn) (list 'scoped (gnode-name gn)))
247 |    ((parent-gnode? gn) (list 'list (gnode-name gn)))
248 |    ((terminal-gnode? gn) (list 'terminal (gnode-name gn)))
249 |    ((variable-gnode? gn) (list 'var (gnode-name gn)))
250 |    ((argument-gnode? gn) (list 'arg (gnode-name gn)))
251 |    (#t 'unknown 'unknown))))
252 | 
253 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254 | ;;;                                                                   Updating and Related                                                                  ;;;
255 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
256 | 
257 | (define (package-up id2)
258 |  (list id2 (cadr (get-written id2))))
259 | 
260 | (define free-variables (hash))
261 | (define bound-variables (hash))
262 | 
263 | (define (update-data)
264 |  (set! free-variables (hash))
265 |  (set! bound-variables (hash))
266 |  (update-free-variables)
267 |  (update-bound-variables))
268 | 
269 | (define (update-free-variables)
270 |  (with
271 |   ((for-each
272 |     update-free-variable-id
273 |     (graph-ids G)))
274 | 
275 |   (update-free-variable-id (id)
276 |    (let ((gn (hash-ref G id)))
277 |     (with
278 |      ((if (hash-has-key? free-variables id)
279 |        '()
280 |        (begin
281 |         (set! free-variables (hash-set free-variables id '()))
282 |         (set! free-variables (hash-set free-variables id (set-map (set-subtract (list->set (free-from-children)) (list->set (defined-here))) package-up))))))
283 | 
284 |      (free-from-children ()
285 |       (remove-duplicates
286 |        (flatten
287 |         (append
288 |          (get-free-variables-from-children)
289 |          (get-new-free-variables)))))
290 | 
291 |      (get-free-variables-from-children ()
292 |       (map
293 |        (lambda (child) (update-free-variable-id child) (map (lambda (p) (car p)) (hash-ref free-variables child)))
294 |        (cond
295 |         ((parent-gnode? gn) (parent-gnode-childs gn))
296 | 	((variable-gnode? gn) (list (variable-gnode-defined gn)))
297 | 	(#t '()))))
298 | 
299 |      (get-new-free-variables ()
300 |       (if (or (variable-gnode? gn) (argument-gnode? gn))
301 |        (list id)
302 |        '()))
303 | 
304 |      (defined-here ()
305 |       (cond
306 |        ((parent-gnode? gn) (parent-gnode-vars gn))
307 |        ((function-gnode? gn) (function-gnode-args gn))
308 |        (#t '()))))))))
309 | 
310 | (define (update-bound-variables)
311 |  (let update-bound-variable-id ((id 0) (from-above '()))
312 |   (let* ((gn (hash-ref G id))
313 |          (bound (append from-above (if (parent-gnode? gn) (parent-gnode-vars gn) '()) (if (function-gnode? gn) (function-gnode-args gn) '()))))
314 |    (for-each (curryr update-bound-variable-id bound) (lexical-children id))
315 |    (if (hash-has-key? bound-variables id)
316 |     '()
317 |      (set! bound-variables (hash-set bound-variables id (map package-up from-above)))))))
318 | 
319 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320 | ;;;                                                                           Go                                                                            ;;;
321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 | 
323 | (define (main input-file)
324 |  (read-file input-file)
325 |  (set! GRFILE input-file)
326 |  (set! Next-id (hash-ref G 'next-id))
327 |  
328 |  (define (yup)
329 |   (display-on-screen 0 330 WIDTH (- HEIGHT 330) (list 0 'list '() '() '() '() '() '()) child-fun)
330 |   (display "um, so yeah\n"))
331 |  
332 |  (if NEWCODE
333 |   (graph->file G)
334 |   '())
335 |  
336 |  (update-data)
337 |  
338 |  (yup))
339 | 
340 | 


--------------------------------------------------------------------------------
/core/find.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "graph.rkt")
 4 | 
 5 | ; Return all triples for which (pred t) returns true.
 6 | (define (graph-filter g pred)
 7 |  (filter pred (graph-edges g)))
 8 | 
 9 | ; Return all triples joined to 'v'.
10 | ; This is graph-neighborhood-foward union graph-neighborhood-backward.
11 | (define (graph-neighborhood g v)
12 |  (append (graph-neighborhood-forward g v) (graph-neighborhood-backward g v)))
13 | 
14 | ; Return all triples with 'v' as the start.
15 | (define (graph-neighborhood-forward g v)
16 |  (graph-filter g (lambda (t) (equal? (triple-start t) v))))
17 | 
18 | ; Return all triples with 'v' as the end
19 | (define (graph-neighborhood-backward g v)
20 |  (graph-filter g (lambda (t) (equal? (triple-end t) v))))
21 | 
22 | ; Start at an initial point and return all triples in the tree created by following
23 | ; a particular type of edge.  endpoint1 is a predicate that returns true if the triple
24 | ; is in the tree, and endpoint2 is a predicate that returns which element to use as
25 | ; the next initial element.  This is an auxiliary function -- most will want to use
26 | ; graph-follow-forward or graph-follow-backward.
27 | (define (graph-follow-aux g v edge endpoint1 endpoint2)
28 |  (let* ((matches (graph-neighborhood-edge-aux g v edge endpoint1)))
29 |   (append
30 |    matches
31 |    (flatten (map (lambda (t) (graph-follow-aux g (endpoint2 t) edge endpoint1 endpoint2)) matches)))))
32 | 
33 | ; Return all triples connected by 'edge' to 'v'.
34 | ; That is, the tree created by recursively following 'edge'.  This is
35 | ; graph-follow-forward union graph-follow-backward.
36 | (define (graph-follow g v edge)
37 |  (append (graph-follow-forward g v edge) (graph-follow-backward g v edge)))
38 | 
39 | ; Return all triples connected by 'edge' to 'v' in the forward direction.
40 | ; That is, the tree created by recursively following 'edge' in the forward
41 | ; direction.
42 | (define (graph-follow-forward g v edge)
43 |  (graph-follow-aux g v edge triple-start triple-end))
44 | 
45 | ; Return all triples connected by 'edge' to 'v' in the backward direction.
46 | ; That is, the tree created by recursively following 'edge' in the backward
47 | ; direction.
48 | (define (graph-follow-backward g v edge)
49 |  (graph-follow-aux g v edge triple-end triple-start))
50 | 
51 | ; Auxiliary function.  Return all triples joined to 'v' by following 'edge' where
52 | ; pred determines which endpoint to use.
53 | (define (graph-neighborhood-edge-aux g v edge pred)
54 |  (graph-filter g (lambda (t) (and (equal? (triple-edge t) edge) (eq? (pred t) v)))))
55 | 
56 | ; Find all triples joined by 'edge' to 'v'.
57 | ; This is graph-neighborhood-edge-forward union graph-neighborhood-edge-backward.
58 | (define (graph-neighborhood-edge g v edge)
59 |  (append (graph-neighborhood-edge-forward g v edge) (graph-neighborhood-edge-backward g v edge)))
60 | 
61 | ; Find all triples joined by 'edge' to 'v' in the forward direction.
62 | (define (graph-neighborhood-edge-forward g v edge)
63 |  (graph-neighborhood-edge-aux g v edge triple-start))
64 | 
65 | ; Find all triples joined by 'edge' to 'v' in the backward direction.
66 | (define (graph-neighborhood-edge-backward g v edge)
67 |  (graph-neighborhood-edge-aux g v edge triple-end))
68 | 
69 | (define (graph-edge-neighborhood g edge)
70 |  (graph-filter g (lambda (t) (equal? (triple-edge t) edge))))
71 | 
72 | (provide (all-defined-out))
73 | 
74 | 


--------------------------------------------------------------------------------
/core/gnode.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (provide (all-defined-out))
 4 | 
 5 | (struct gnode (id name) #:prefab)
 6 | 
 7 | (struct parent-gnode gnode (childs vars) #:prefab)
 8 | 
 9 | (struct variable-gnode gnode (defined) #:prefab)
10 | 
11 | (struct function-gnode variable-gnode (args) #:prefab)
12 | 
13 | (struct argument-gnode gnode ((argument #:auto)) #:auto-value #t #:prefab)
14 | 
15 | (struct terminal-gnode gnode ((terminal #:auto)) #:auto-value #t #:prefab)
16 | 
17 | 


--------------------------------------------------------------------------------
/core/graph.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ; Remove vertex list
  4 | 
  5 | (require racket/set)
  6 | 
  7 | (provide (except-out (all-defined-out) replace))
  8 | 
  9 | (struct graph (vertices edges) #:prefab)
 10 | (struct triple (start edge end) #:prefab)
 11 | 
 12 | (define (string->graph str)
 13 |  (let* ((lines (filter (lambda (line) (not (equal? line ""))) (regexp-split #rx"\n" str)))
 14 |         (edges (map (lambda (line) (apply triple (regexp-split #rx"\t" line))) lines)))
 15 |   (graph
 16 |    (apply set-union (map (lambda (e) (set (triple-start e) (triple-end e))) edges))
 17 |    edges)))
 18 | 
 19 | (define (graph->string g)
 20 |  (apply string-append (map (lambda (t) (string-append (format "~s" (triple-start t)) "\t" (format "~s" (triple-edge t)) "\t" (format "~s" (triple-end t)) "\n")) (graph-edges g))))
 21 | 
 22 | (define (display-graph g)
 23 |  (set-for-each (graph-vertices g) (lambda (t) (display t) (display "\t")))
 24 |  (newline)
 25 |  (newline)
 26 |  (for-each display-triple (graph-edges g)))
 27 | 
 28 | (define (display-triple t)
 29 |  (display (triple-start t)) (display " --> ") (display (triple-edge t)) (display " --> ") (display (triple-end t)) (newline))
 30 | 
 31 | (define (triple->list t)
 32 |  (list (triple-start t) (triple-edge t) (triple-end t)))
 33 | 
 34 | (define (create-triples v1 e v2)
 35 |  (flatten 
 36 |   (let* ((len (cond
 37 |                ((list? v1) (length v1))
 38 |                ((list? e) (length e))
 39 |                ((list? v2) (length v2))
 40 |                (#t 1))))
 41 |    (map
 42 |     (lambda (vv1 ee vv2)
 43 |      (if (or (list? vv1) (list? ee) (list? vv2))
 44 |       (create-triples vv1 ee vv2)
 45 |       (triple vv1 ee vv2)))
 46 |     (if (list? v1) v1 (make-list len v1))
 47 |     (if (list? e) e (make-list len e))
 48 |     (if (list? v2) v2 (make-list len v2))))))
 49 | 
 50 | (define (graph-neighborhood-forward g v)
 51 |  (car (hash-ref g v)))
 52 | 
 53 | (define (graph-neighborhood-edge-forward g v edge)
 54 |  (filter (lambda (e) (equal? edge (triple-edge e))) (car (hash-ref g v '(() . ())))))
 55 | 
 56 | (define (graph-neighborhood-backward g v)
 57 |  (cdr (hash-ref g v)))
 58 | 
 59 | (define (graph-neighborhood-edge-backward g v edge)
 60 |  (filter (lambda (e) (equal? edge (triple-edge e))) (cdr (hash-ref g v '(() . ())))))
 61 | 
 62 | (define (graph-append-edges g edges)
 63 |  (foldl (lambda (e h) (graph-append-edge h e)) g edges))
 64 | 
 65 | (define (graph-append-edge g edge)
 66 |  (let* ((v1 (triple-start edge))
 67 |         (v2 (triple-end edge))
 68 |         (h (hash-set g v1 (cons (append (car (hash-ref g v1 '(() . ()))) (list edge)) (cdr (hash-ref g v1 '(() ()))))))
 69 |         (hh (hash-set h v2 (cons (car (hash-ref g v2 '(() . ()))) (append (cdr (hash-ref g v2 '(() . ()))) (list edge))))))
 70 |   hh))
 71 | 
 72 | (define (graph-prepend-edges g edges)
 73 |  (foldl (lambda (e h) (graph-prepend-edge h e)) g edges))
 74 | 
 75 | (define (graph-prepend-edge g edge)
 76 |  (let* ((v1 (triple-start edge))
 77 |         (v2 (triple-end edge))
 78 |         (h (hash-set g v1 (cons (append (list edge) (car (hash-ref g v1))) (cdr (hash-ref g v1)))))
 79 |         (hh (hash-set h v2 (cons (car (hash-ref g v2 '(() . ()))) (append (cdr (hash-ref g v2 '(() . ()))) (list edge))))))
 80 |   hh))
 81 | 
 82 | (define (graph-replace-edges g edge edges)
 83 |  (let* ((v1 (triple-start edge))
 84 |         (v2 (triple-end edge))
 85 |         (h (hash-set g v1 (cons (replace edge edges (car (hash-ref g v1))) (cdr (hash-ref g v1)))))
 86 |         (hh (hash-set h v2 (cons (car (hash-ref h v2 '(() . ()))) (remove edge (cdr (hash-ref h v2 '(() . ()))))))))
 87 |   (foldl (lambda (e hhh)
 88 |           (let* ((vv2 (triple-end e))
 89 |                  (hhhh (hash-set hhh vv2 (cons (car (hash-ref hhh vv2 '(() . ()))) (append (cdr (hash-ref hhh vv2 '(() . ()))) (list e))))))
 90 |            hhhh))
 91 |          hh
 92 |          edges)))
 93 | 
 94 | (define (replace t1 t2s es)
 95 |  (append (takef es (negate (curry equal? t1))) t2s (cdr (member t1 es))))
 96 | 
 97 | (define (graph-remove-edge g edge)
 98 |  (let* ((v1 (triple-start edge))
 99 |         (v2 (triple-end edge))
100 |         (h (hash-set g v1 (cons (remove edge (car (hash-ref g v1))) (cdr (hash-ref g v1)))))
101 |         (hh (hash-set h v2 (cons (car (hash-ref h v2 '(() . ()))) (remove edge (cdr (hash-ref h v2 '(() . ()))))))))
102 |   hh))
103 | 
104 | 


--------------------------------------------------------------------------------
/core/main.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "disp.rkt")
 4 | (require "extractdata.rkt")
 5 | 
 6 | (define bg-file "")
 7 | 
 8 | (define filename
 9 |  (command-line
10 |   #:program "phlisped"
11 |   #:once-each
12 |   (("-b" "--background") background-file "background image (as used by visualization) (not implemented)"
13 |    (set! bg-file background-file))
14 |   #:args
15 |   (filename)
16 |   filename))
17 | 
18 | (main filename)
19 | 
20 | (require (for-syntax racket/system))
21 | (define-syntax (require-dir syn)
22 |  (let* ((dir (cadr (syntax->datum syn)))
23 |         (phls (map (lambda (f) (string-append dir "/" f)) (filter (lambda (f) (regexp-match ".phl$" f)) (map path->string (directory-list dir))))))
24 |   (for-each (lambda (phl) (system* "bin/phlisp" (string-append "-o " (regexp-replace ".phl$" phl ".rkt")) phl)) phls)
25 |   (let* ((rkts (map (lambda (f) (string-append "../" dir "/" f)) (filter (lambda (f) (regexp-match ".rkt$" f)) (map path->string (directory-list dir)))))
26 |          (rkts2 (map (lambda (rkt) `(prefix-in ,(string->symbol (string-append "com-" rkt ":")) ,rkt)) rkts))
27 | 	 (regs (map (lambda (rkt) (string->symbol (string-append "com-" rkt ":data"))) rkts))
28 | 	 (datas (map (lambda (reg) `(process ,reg)) regs)))
29 |    (datum->syntax syn `(begin
30 | 			(require ,@rkts2)
31 | 			(add-key-evs (append ,@datas)))))))
32 | 
33 | (define (process reg)
34 |  (flatten
35 |   (let loop ((r reg))
36 |    (if (or (null? r) (null? (cdr r)))
37 |     '()
38 |     (append
39 |      (map (lambda (key) (list key (cadr r))) (car r))
40 |      (loop (cddr r)))))))
41 | 
42 | (require-dir "commands")
43 | 
44 | 


--------------------------------------------------------------------------------
/core/phlisp.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "compiler.rkt")
 4 | 
 5 | (define run-code #f)
 6 | (define out-file #f)
 7 | 
 8 | (define filename
 9 |  (command-line
10 |   #:program "phlisp"
11 |   #:once-each
12 |   (("-o" "--output") output-file "output compiled code to file (default is stdout)"
13 |    (set! out-file output-file))
14 |   (("-r" "--run") "run code"
15 |    (set! run-code #t))
16 |   #:args
17 |   (filename)
18 |   filename))
19 | 
20 | (define G (call-with-input-file filename (lambda (f) (read f))))
21 | (define compiled (reify G 0 #f))
22 | (if out-file
23 |  (call-with-output-file out-file #:exists 'truncate (lambda (f) (display "#lang racket\n\n" f) (map (curryr displayln f) compiled)))
24 |  (map display compiled))
25 | (when run-code
26 |  (let ((ns (make-base-namespace)))
27 |   (eval compiled ns)))
28 | 
29 | 


--------------------------------------------------------------------------------
/doc/phlisp.md:
--------------------------------------------------------------------------------
 1 | phlisp
 2 | ======
 3 | 
 4 | Philosophy
 5 | ----------
 6 | 
 7 | Phlisp is a lisp-like language that is defined as a directed, partially ordered, labeled graph (hereafter the "abstract syntax graph" or "ASG").  Phlisp's main influences are members of the lisp family, particularly Racket.  The purpose of phlisp is to create a language that may be edited not with a text editor but with a tree/graph editor built for the purpose.  The canonical implementation is phlisped.
 8 | 
 9 | Phlisp code compiles to Racket code, which may then be run with the standard Racket utilities.  Most phlisp code translates fairly directly to Racket.  The main functional additions are related to defining variables.  Instead of using `define` and `let` statements, we have each reference to a variable simply reference the same node in the ASG.  These variables are assigned a particular environment node and may be referenced in any lexical descendant of that node.  In this way, all cross references are direct, and variable handling is greatly simplified.
10 | 
11 | Additionally, functions are defined in a manner very similar to variables.  The main differences are obviously that functions are evaluated explicitly when they are referenced rather than implicitly at the level of the environment node and functions may have parameters.  Note that for a pure function, the only difference is that functions may have parameters (and so variables are merely the zero-parameter special case of functions).  In practice, though, mutating state is a fact of life, so we maintain the distinction.  Thus, in phlisp, we mark variables as functions rather than using `lambda` explicitly.
12 | 
13 | The Graph
14 | ---------
15 | 
16 | All nodes in the graph are distinguishable.  All lists are assumed unordered unless explicitly specified as ordered.  All nodes must have a name.  A node must be exactly one of the following:
17 | 
18 | - a parent of one or more nodes
19 | - a variable defined as another node
20 | - an argument to a function
21 | - a terminal node
22 | 
23 | ### Parent Nodes
24 | 
25 | Parent nodes must have one or more ordered parent, variable, or terminal node children.  They may have one or more variable node vars.
26 | 
27 | ### Variable Nodes
28 | 
29 | Variable nodes have exactly one parent, variable, terminal, or argument node definition.  They may be labeled `is-function`.  If so, then we call it a function node, and it may have one or more ordered argument node arguments.
30 | 
31 | ### Argument Nodes
32 | 
33 | Argument nodes must be labeled as such.
34 | 
35 | ### Terminal Nodes
36 | 
37 | Terminal nodes must be labeled as such.
38 | 
39 | Compilation
40 | -----------
41 | 
42 | The compilation of any node is dependent only on the lexical children of that node.  Compilation follows the following algorithm.
43 | 
44 | Define `c(n)` such that if `n` is a:
45 | 
46 | - variable node, then if `id` is a unique symbol associated with `n`, yield `id`.
47 | - terminal node, then if `n` has name `name`, yield `name`.
48 | - parent node, let `n` have `r` child nodes labeled `child1 child2 ... childr` and `s` vars `var1 var2 ... vars` with unique associated symbols `id1 id2 .. ids`.  For each `varp`, let `resp` be `c(varp)` if `varp` is not a function node, else let `varp` have `t` formal arguments labeled `arg1 arg2 ... argt` with unique associated symbols `idp1 idp2 ... idpt` and let `resp` be `(lambda (idp1 idp2 ... idpt) c(varp))`  yield `(letrec ((id1 res1) (id2 res2) ... (ids ress)) (c(child1) c(child2) ... c(childs)))`.  Note that since vars is unordered, to get the ordering, we topologically sort the ends such that if the definition of `varp` references `varq` in any place other than a function definition, then `varp` precedes `varq`.
49 | 


--------------------------------------------------------------------------------
/doc/spec:
--------------------------------------------------------------------------------
  1 | Copyright Philip Monk, August 2013, All rights reserved.
  2 | 
  3 | Language
  4 | ========
  5 | 
  6 | A program is a directed, labeled, partially ordered graph.
  7 | 
  8 | The triples have an ordering.  Although implemented as a total ordering, the only comparisons that should be relied upon are those with the same start and edge values.  The ordering of backward edges is not defined.  The only edges where this is applicable are the "has child", "has arg", and "has formal arg".  All other edges are singletons, i.e. for each start there must be no more than one triple with any given edge.
  9 | 
 10 | "is" may only be used with start next-id.
 11 | 
 12 | If alice is defined as bob, then bob must have env.
 13 | 
 14 | If unexpected edges exist, they should be ignored.
 15 | 
 16 | Edges:
 17 |         "has child"
 18 |         "has arg"
 19 |         "has formal arg"
 20 | 	"is defined as"
 21 | 	"is named"
 22 | 	"is written"
 23 | 	"is reified as"
 24 | 	"is call to"
 25 | 	"has scope"
 26 | 	"has env"
 27 | 	"is"
 28 | 
 29 | May (x) or must (Y) be used in conjunction with: (Y means if the row-edge is present, then the column-edge must be present, but the converse is not necessarily true)
 30 | 
 31 | 	hc	ha	hfa	ida	in	iw	ira	ict	hs	he	is
 32 | hc	x		x		x				x
 33 | ha		x	x		x			Y	x
 34 | hfa	x	x	x	x	x	x		x	Y	
 35 | ida			x		x				x	Y
 36 | in	x	x	x	x				x	x	x
 37 | iw			x				x		x
 38 | ira						Y
 39 | ict		x	x		x				x
 40 | hs	x	x	x	x	x	x		x
 41 | he			x	x	x
 42 | is
 43 | 
 44 | 	hc	hfa	ida	in	iw	ira	he	if	is
 45 | hc	x			x			
 46 | hfa		x	Y	x			Y	Y
 47 | ida		x		x			Y	x
 48 | in	x	x	x				x	x
 49 | iw						x
 50 | ira					Y
 51 | he		x	x	x				x
 52 | if		x	Y	x			x
 53 | is
 54 | 
 55 | Language implementation
 56 | =======================
 57 | 
 58 | The program graph is implemented as a hash where each entry has the form (id --> (l1 . l2)) where l1 is a list of the edges starting at id and l2 is a list of the edges ending at id.
 59 | 
 60 | graph-neighborhood-{forward,backward} returns {l1,l2}, graph-neighborhood-edge-{forward,backward} returns {l1,l2} filtered for the requested edge.
 61 | 
 62 | For all modifications, we must preserve the ordering of each l1.  Right now, l2 is in order of date added, but this should not be depended on.
 63 | 
 64 | graph-append-edge{s} returns a new hash with e{s} appended to the l1 associated with (triple-start {(car }e{)}) and added to the l2{s} associated with (triple-end e{s}).
 65 | 
 66 | graph-prepend-edge{s} returns a new hash with e{s} prepended to the l1 associated with (triple-start {(car }e{)}) and added to the l2{s} associated with (triple-end e{s}).
 67 | 
 68 | graph-replace-edges returns a new hash with es replacing e in the l1 associated with (triple-start e) and e removed from the l2 assoiciated with (triple-end e) and es added to the l2{s} associated with each of (triple-end es).  Note that all es must have the same triple-start.
 69 | 
 70 | graph-remove-edge returns a new hash with e removed from the l1 associated with (triple-start e) and the l2 associated with (triple-end e).
 71 | 
 72 | Trees
 73 | =====
 74 | 
 75 | Trees is a list of whole-tree.
 76 | 
 77 | The first element of Trees must be a dummy tree, the second element must be the Bar-tree, and there must always be a third element.  The contents of the dummy tree should never have a functional impact.
 78 | 
 79 | Selected-tree
 80 | =============
 81 | 
 82 | Selected-tree must always point to a valid tree.
 83 | 
 84 | Bar-tree
 85 | ========
 86 | 
 87 | Bar-tree must always point to a valid tree.
 88 | 
 89 | whole-tree
 90 | ==========
 91 | 
 92 | A whole-tree contains all the data necessary to display a tree on the screen.
 93 | 
 94 | n-tree is a valid node.
 95 | 
 96 | childfunc is a function that takes one argument (namely, the data of a particular node), and returns the children of this node in the current tree.  This function should return the same value each time it is called with the same input.  If this function is changed, the n-tree and utterance-tree should be regenerated and the selection and open set cleared.
 97 | 
 98 | utterance-tree is a tree of utterances.  utterance-node should provide an injective mapping from the utterances in utterance-tree to the nodes in n-tree.
 99 | 
100 | open is a set of laddrs.  Each laddr must correspond to a valid utterance.
101 | 
102 | selection is a laddr.  selection must correspond to a valid utterance.
103 | 
104 | x y w h offset-x offset-y zoom are numbers.  zoom must be positive.
105 | 
106 | utterance
107 | =========
108 | 
109 | An utterance contains all the data necessary to display a single node.
110 | 
111 | node is a valid node.
112 | 
113 | x y w h text-w text-h are nonnegative numbers.
114 | 
115 | args is an eargerly-evaluated list of utterances.  An utterance may not be its own descendant.
116 | 
117 | clr is a pair of the form (f . b) where f is a foreground color and b is a background color.  Both f and b are lists of length three representing rgb on a scale of 0-255.
118 | 
119 | runtime-vals
120 | ============
121 | 
122 | runtime-vals is a mutable hash from ids to a list of values.  The order of the values is such that as soon as a value for a particular id is known, it is added to the end.  Thus, it is in order of _exits_, not _entrances_ into a node.  If we want to change that, then we'd need to come up with a way to put in placeholders as we're stepping through and at the end replace them with the value.  This is very doable, I'm just not sure if it's the correct design decision.
123 | 
124 | visualization
125 | =============
126 | 
127 | A visualization must implement the following functions:
128 | 
129 | * paint-tree
130 | * node->v11n-utterance
131 | * wheel {'left,'right,'up,'down}
132 | * find-utterance
133 | 
134 | A visualization may implement the following functions:
135 | 
136 | * zoom
137 | 


--------------------------------------------------------------------------------
/tests/skeleton.phl:
--------------------------------------------------------------------------------
1 | #hash((0 . #s((terminal-gnode (1 #t) gnode 2) 0 - #t)) (next-id . 1))
2 | 


--------------------------------------------------------------------------------
/tests/test-extractdata.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require rackunit
  4 |          racket/gui
  5 |          "../core/disp.rkt"
  6 |          "../core/extractdata.rkt")
  7 | 
  8 | (test-case
  9 |  "basic functionality"
 10 |  (read-file "testdata")
 11 |  (check-not-false (hash-has-key? G 0) "has no root element")
 12 |  (check-false (hash-has-key? G -1) "failed basic sanity check"))
 13 | 
 14 | (define (type c)
 15 |  (send Thecanvas on-char (new key-event% (key-code c))))
 16 | 
 17 | (define (clean)
 18 |  (read-file "testdata")
 19 |  (updater)
 20 |  (set-whole-tree-open! Selected-tree (set))
 21 |  (set-whole-tree-selection! Selected-tree '()))
 22 | 
 23 | (type #\tab)
 24 | 
 25 | (test-case
 26 |  "read-only manipulation"
 27 |  (clean)
 28 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 0 "not starting with all nodes closed")
 29 |  (check-eq? (whole-tree-selection Selected-tree) '() "not starting with correct selection")
 30 |  (type #\O)
 31 |  (check-not-eq? (set-count (whole-tree-open Selected-tree)) 0 "deep open not opening any nodes")
 32 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 3 "deep open opening incorrect number of nodes")
 33 |  (type #\O)
 34 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 3 "consecutive deep opens opening more nodes")
 35 |  (type #\j)
 36 |  (check-equal? (whole-tree-selection Selected-tree) '(0) "move down not moving to correct address")
 37 |  (type #\l)
 38 |  (type #\l)
 39 |  (check-equal? (whole-tree-selection Selected-tree) '(2) "move right not moving to correct address")
 40 |  (type #\h)
 41 |  (check-equal? (whole-tree-selection Selected-tree) '(1) "move left not moving to correct address")
 42 |  (type #\k)
 43 |  (check-equal? (whole-tree-selection Selected-tree) '() "move up not moving to correct address")
 44 |  (type #\0)
 45 |  (check-equal? (whole-tree-selection Selected-tree) '(0) "move to nth child not moving to correct address")
 46 |  (type #\k)
 47 |  (type #\1)
 48 |  (check-equal? (whole-tree-selection Selected-tree) '(1) "move to nth child not moving to correct address")
 49 |  (type #\k)
 50 |  (type #\2)
 51 |  (check-equal? (whole-tree-selection Selected-tree) '(2) "move to nth child not moving to correct address")
 52 |  (type #\k)
 53 |  (type #\j)
 54 |  (type #\o)
 55 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 4 "shallow open not opening any nodes")
 56 |  (type #\O)
 57 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 38 "deep open opening incorrect number of nodes")
 58 |  (type #\0)
 59 |  (type #\2)
 60 |  (type #\O)
 61 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 57 "deep open opening incorrect number of nodes")
 62 |  (type #\c)
 63 |  (type #\c)
 64 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 40 "shallow close closing incorrect number of nodes")
 65 |  (type #\O)
 66 |  (type #\C)
 67 |  (check-eq? (set-count (whole-tree-open Selected-tree)) 38 "deep close closing incorrect number of nodes")
 68 |  )
 69 | 
 70 | (test-case
 71 |  "add sibling"
 72 |  (clean)
 73 |  (type #\O)
 74 |  (type #\j)
 75 |  (check-equal? (whole-tree-open Selected-tree) (set '() '(1) '(2)) "not starting with correct open nodes")
 76 |  (type #\space)
 77 |  (check-equal? (whole-tree-open Selected-tree) (set '() '(1) '(2) '(3)) "after adding sibling, not correct open nodes")
 78 |  (test-begin
 79 |   (clean)
 80 |   (type #\O)
 81 |   (type #\0)
 82 |   (type #\O)
 83 |   (type #\0)
 84 |   (type #\2)
 85 |   (type #\O)
 86 |   (type #\0)
 87 |   (type #\2)
 88 |   (type #\2)
 89 |   (type #\0)
 90 |   (type #\O)
 91 |   (type #\0)
 92 |   (type #\1)
 93 |   (type #\0)
 94 |   (type #\1)
 95 |   (type #\space)
 96 |   (check-equal? (whole-tree-open Selected-tree)
 97 |                 (list->set '(() (0) (1) (2) (0 0) (0 2) (0 1) (0 0 0) (0 0 1) (0 0 2) (0 0 3) (0 0 3 0) (0 0 3 1) (0 0 3 3) (0 0 2 0) (0 0 1 2) (0 0 1 0) (0 0 1 1) (0 0 2 0 2 2 0 0) (0 0 2 0 2 2 0 1) (0 0 2 0 2 2 0 2) (0 0 2 0 2 2 0 3) (0 0 2 0 2 2 0 0 1 0 3 2) (0 0 2 0 2 2 0 0 1 0 3 1) (0 0 2 0 2 2 0 0 1 0 3 0) (0 0 3 1 2 1 1 0) (0 0 3 1 2 1 1 1) (0 0 2 0 2 2 0 0 6 0 2 2) (0 0 2 0 2 2 0 0 6 0 2 0) (0 0 2 0 2 2 0 0 6 0 2 1) (0 0 2 0 2 2 0 0 1 1) (0 0 2 0 2 2 0 0 1 0) (0 0 2 0 2 2 0 0 2 0) (0 0 2 0 2 2 0 0 2 1) (0 0 2 0 2 2 0 0 4 0) (0 0 2 0 2 2 0 0 4 1) (0 0 2 0 2 2 0 0 5 0) (0 0 2 0 2 2 0 0 5 1) (0 0 2 0 2 2 0 0 3 0) (0 0 2 0 2 2 0 0 3 1) (0 0 2 0 2 2 0 0 6 1) (0 0 2 0 2 2 0 0 6 0) (0 0 2 0 2 2 0 0 2) (0 0 2 0 2 2 0 0 1) (0 0 2 0 2 2 0 0 0) (0 0 2 0 2 2 0 0 6) (0 0 2 0 2 2 0 0 5) (0 0 2 0 2 2 0 0 4) (0 0 2 0 2 2 0 0 3) (0 0 2 0 2 2 0 0 5 0 2 0) (0 0 2 0 2 2 0 0 5 0 2 2) (0 0 2 0 2 2 0 0 5 0 2 1) (0 0 3 1 2 1 1) (0 0 3 1 2 1 0) (0 0 3 1 1 1 0) (0 0 2 0 2 2 0 0 3 0 2 2) (0 0 2 0 2 2 0 0 3 0 2 1) (0 0 2 0 2 2 0 0 3 0 2 0) (0 0 3 3 1 1 1 0) (0 0 3 3 1 1 0) (0 0 3 3 1 1 1) (0 0 2 0 2 2 0 0 4 0 2 0) (0 0 2 0 2 2 0 0 4 0 2 1) (0 0 2 0 2 2 0 0 4 0 2 2) (0 0 3 1 1 1) (0 0 3 1 1 0) (0 0 3 1 2 0) (0 0 3 1 2 1) (0 0 3 3 1 0) (0 0 3 3 1 1) (0 0 2 0 2 2 0) (0 0 2 0 2 2 1) (0 0 2 0 2 2 2) (0 0 2 0 2 2 3) (0 0 2 0 2 1 1) (0 0 2 0 2 1 2) (0 0 2 0 2 1 0) (0 0 2 0 1 1 0) (0 0 2 0 1 1 1) (0 0 2 0 1 1 2) (0 0 2 0 2 2 0 0 2 0 2 2) (0 0 2 0 2 2 0 0 2 0 2 1) (0 0 2 0 2 2 0 0 2 0 2 0) (0 0 2 0 2 0) (0 0 2 0 2 1) (0 0 2 0 2 2) (0 0 2 0 1 0) (0 0 2 0 1 1) (0 0 3 1 2 1 1 1 0) (0 0 2 0 2 2 0 0 1 1 3) (0 0 2 0 2 2 0 0 1 1 0) (0 0 2 0 2 2 0 0 1 0 0) (0 0 2 0 2 2 0 0 1 0 3) (0 0 2 0 2 2 0 0 1 0 2) (0 0 2 0 2 2 0 0 6 0 2) (0 0 2 0 2 2 0 0 6 0 0) (0 0 2 0 2 2 0 0 6 1 2) (0 0 2 0 2 2 0 0 6 1 0) (0 0 2 0 2 2 0 0 5 1 0) (0 0 2 0 2 2 0 0 5 1 2) (0 0 2 0 2 2 0 0 5 0 2) (0 0 2 0 2 2 0 0 5 0 0) (0 0 2 0 2 2 0 0 3 0 0) (0 0 2 0 2 2 0 0 3 0 2) (0 0 2 0 2 2 0 0 3 1 0) (0 0 2 0 2 2 0 0 3 1 1) (0 0 2 0 2 2 0 0 4 0 2) (0 0 2 0 2 2 0 0 4 0 0) (0 0 2 0 2 2 0 0 4 1 0) (0 0 2 0 2 2 0 0 4 1 1) (0 0 2 0 2 2 0 0 2 0 2) (0 0 2 0 2 2 0 0 2 0 0) (0 0 2 0 2 2 0 0 2 1 3) (0 0 2 0 2 2 0 0 2 1 0) (0 0 3 1 2) (0 0 3 1 1) (0 0 3 1 0) (0 0 3 3 1) (0 0 3 3 0) (0 0 2 0 0) (0 0 2 0 1) (0 0 2 0 2) (0 0 1 2 0) (0 0 1 1 0)))
 98 |                 "add sibling next to variable leaving wrong open set"))
 99 |  )
100 | 
101 | 
102 | (exit)
103 | 


--------------------------------------------------------------------------------
/visualizations/README.md:
--------------------------------------------------------------------------------
1 | Visualizations
2 | ==============
3 | 
4 | This is the readme for the visualizations directory.
5 | 
6 | All of the available visualizations are in this directory.
7 | 
8 | A visualization must provide the symbol `visualization` as a v11n.  v11ns are defined in core/common.ss.
9 | 


--------------------------------------------------------------------------------
/visualizations/default-horizontal-v11n.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require sgl sgl/gl)
  4 | (require "../core/common.rkt")
  5 | (require "helpers/default-v11n.rkt")
  6 | 
  7 | (provide visualization)
  8 | 
  9 | (define visualization
 10 |  (make-default-v11n
 11 |   #:child-w-generator (lambda (n) -1)
 12 |   #:child-x-generator (lambda (data w n) (car data))
 13 |   #:child-y-generator (lambda (data arg tree) (+ (cadr data) (node-height arg tree)))
 14 |   #:update-x-generator (lambda (data res) (+ (car data) (cartesian-utterance-w res)))
 15 |   #:update-y-generator (lambda (data res arg tree) (cadr data))
 16 |   #:width-generator (lambda (w n children) (max (box-width ((node-text-func n) n)) (apply + (map cartesian-utterance-w children))))
 17 |   #:height-generator (lambda (n tree) CELLHEIGHT)))
 18 | 
 19 | ;(define default-v11n
 20 | ; (v11n
 21 | ;  (def-painter
 22 | ;   #:drawer
 23 | ;    (lambda (text x y w h text-w text-h clr u tree center)
 24 | ;     (draw-rectangle (if (eq? Selected-tree tree) (cdr clr) (map (curryr / 3) (cdr clr))) x y w h)
 25 | ;     (if (and (< (/ (- text-w PADDING) (whole-tree-zoom tree)) w)
 26 | ;              (< (/ text-h (whole-tree-zoom tree)) h))
 27 | ;      (draw-text
 28 | ;       text
 29 | ;       (center x w (- text-w PADDING) (- (whole-tree-offset-x tree)) (whole-tree-w tree))
 30 | ;       (+ text-h -3 (center y h text-h (- (whole-tree-offset-y tree)) (whole-tree-h tree)))
 31 | ;       (car clr)
 32 | ;       tree)
 33 | ;      '())))
 34 | ;
 35 | ;  (lambda (n x y w row siblings tree)
 36 | ;   (let node->utterance ((n n) (x x) (y y) (w w) (row row) (siblings siblings) (tree tree))
 37 | ;    (with
 38 | ;     ((let ((children 
 39 | ;             (if (closed? n tree)
 40 | ;              '()
 41 | ;              (let ((child-w (if VERTICAL (foldl max 0 (map (lambda (arg) (node-width arg tree)) (node-args n))) -1)))
 42 | ;               (caddr
 43 | ;                (foldl
 44 | ;                 (lambda (arg data)
 45 | ;                  (let ((res (node->utterance
 46 | ;                              arg
 47 | ;                              (if VERTICAL (+ (car data) w) (car data))
 48 | ;                              (if VERTICAL (cadr data) (+ (cadr data) (node-height arg tree)))
 49 | ;                              child-w
 50 | ;                              (+ 1 row)
 51 | ;                              (- (length (node-args n)) 1)
 52 | ;                              tree)))
 53 | ;                   (list
 54 | ;                    (if VERTICAL (car data) (+ (car data) (utterance-w res)))
 55 | ;                    (if VERTICAL (+ (cadr data) (node-height arg tree)) (cadr data))
 56 | ;                    (if (null? res)
 57 | ;                     (caddr data)
 58 | ;                     (append
 59 | ;                      (caddr data)
 60 | ;                      (list res))))))
 61 | ;                 (list x y '())
 62 | ;                 (node-args n)))))))
 63 | ;       (utterance
 64 | ;        n
 65 | ;        x
 66 | ;        y
 67 | ;        (if VERTICAL w (max (box-width ((node-text-func n) n)) (apply + (map utterance-w children))))
 68 | ;        (node-height n tree)
 69 | ;        (box-width ((node-text-func n) n))
 70 | ;        (box-height ((node-text-func n) n))
 71 | ;        children
 72 | ;        (get-color n tree)))))))
 73 | ;
 74 | ;  (lambda (root x y tree)
 75 | ;   (let find-utterance ((root root) (x x) (y y) (tree tree))
 76 | ;    (with
 77 | ;     ((if (or
 78 | ;           (above-bottom-of-utterance?)
 79 | ;           (utterance-is-closed?)
 80 | ;           (has-no-children?)
 81 | ;           (is-to-the-right-of-utterance?))
 82 | ;       root
 83 | ;       (pass-on-to-child)))
 84 | ;   
 85 | ;     (above-bottom-of-utterance? ()
 86 | ;      (< (min-dim x y) (+ (utterance-min-dim root) (utterance-min-dim-span root))))
 87 | ;   
 88 | ;     (utterance-is-closed? ()
 89 | ;      (closed? (utterance-node root) tree))
 90 | ;           
 91 | ;     (has-no-children? ()
 92 | ;      (null? (node-args (utterance-node root))))
 93 | ;   
 94 | ;     (is-to-the-right-of-utterance? ()
 95 | ;      (>= (maj-dim x y) (let ((baby (last (utterance-args root)))) (+ (utterance-maj-dim baby) (utterance-maj-dim-span baby)))))
 96 | ;   
 97 | ;     (pass-on-to-child ()
 98 | ;      (ormap
 99 | ;       (lambda (child)
100 | ;        (if (< (maj-dim x y) (+ (utterance-maj-dim child) (utterance-maj-dim-span child)))
101 | ;         (find-utterance child x y tree)
102 | ;         #f))
103 | ;       (utterance-args root))))))
104 | ;
105 | ;  (lambda (dir event)
106 | ;   (cond
107 | ;    ((eq? dir 'up)
108 | ;     (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))
109 | ;    ((eq? dir 'down)
110 | ;     (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
111 | ;    ((eq? dir 'left)
112 | ;     (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
113 | ;    ((eq? dir 'right)
114 | ;     (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))))))
115 | 
116 | 


--------------------------------------------------------------------------------
/visualizations/default-vertical-v11n.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require sgl sgl/gl)
  4 | (require "../core/common.rkt")
  5 | (require "helpers/default-v11n.rkt")
  6 | 
  7 | (provide visualization)
  8 | 
  9 | (define visualization
 10 |  (make-default-v11n
 11 |   #:child-w-generator (lambda (n) (foldl max 0 (map (lambda (arg) (box-width ((node-text-func arg) arg))) (node-args n))))
 12 |   #:child-x-generator (lambda (data w n) (+ (car data) (if (zero? w) (box-width ((node-text-func n) n)) w)))
 13 |   #:child-y-generator (lambda (data arg tree) (cadr data))
 14 |   #:update-x-generator (lambda (data res) (car data))
 15 |   #:update-y-generator (lambda (data res arg tree) (+ (cadr data) 
 16 |                       (let height ((n arg))
 17 |                        (if (closed? n tree)
 18 |                         (box-height ((node-text-func n) n))
 19 |                         (max
 20 |                          (box-height ((node-text-func n) n))
 21 |                          (foldl + 0 (map height (node-args n))))))
 22 |                                                       ))
 23 |   #:width-generator (lambda (w n children) (if (zero? w) (box-width ((node-text-func n) n)) w))
 24 |   #:height-generator (lambda (n tree)
 25 |                       (let height ((n n))
 26 |                        (if (closed? n tree)
 27 |                         (box-height ((node-text-func n) n))
 28 |                         (max
 29 |                          (box-height ((node-text-func n) n))
 30 |                          (foldl + 0 (map height (node-args n)))))))))
 31 | 
 32 | ;(define (node-maj-dim n tree)
 33 | ; (if (closed? n tree)
 34 | ;  (box-maj-dim ((node-text-func n) (node-data n)))
 35 | ;  (max
 36 | ;   (box-maj-dim ((node-text-func n) (node-data n)))
 37 | ;   (foldl
 38 | ;    +
 39 | ;    0
 40 | ;    (map (lambda (arg) (node-maj-dim arg tree)) (node-args n))))))
 41 | 
 42 | ;(define default-vertical-v11n
 43 | ; (v11n
 44 | ;  (def-painter
 45 | ;   #:drawer
 46 | ;    (lambda (text x y w h text-w text-h clr u tree center)
 47 | ;     (draw-rectangle (if (eq? Selected-tree tree) (cdr clr) (map (curryr / 3) (cdr clr))) x y w h)
 48 | ;     (if (and (< (/ (- text-w PADDING) (whole-tree-zoom tree)) w)
 49 | ;              (< (/ text-h (whole-tree-zoom tree)) h))
 50 | ;      (draw-text
 51 | ;       text
 52 | ;       (center x w (- text-w PADDING) (- (whole-tree-offset-x tree)) (whole-tree-w tree))
 53 | ;       (+ text-h -3 (center y h text-h (- (whole-tree-offset-y tree)) (whole-tree-h tree)))
 54 | ;       (car clr)
 55 | ;       tree)
 56 | ;      '())))
 57 | ;
 58 | ;  (lambda (n x y w row siblings tree)
 59 | ;   (let node->utterance ((n n) (x x) (y y) (w w) (row row) (siblings siblings) (tree tree))
 60 | ;    (with
 61 | ;     ((let ((children 
 62 | ;             (if (closed? n tree)
 63 | ;              '()
 64 | ;              (let ((child-w (if VERTICAL (foldl max 0 (map (lambda (arg) (node-width arg tree)) (node-args n))) -1)))
 65 | ;               (caddr
 66 | ;                (foldl
 67 | ;                 (lambda (arg data)
 68 | ;                  (let ((res (node->utterance
 69 | ;                              arg
 70 | ;                              (if VERTICAL (+ (car data) w) (car data))
 71 | ;                              (if VERTICAL (cadr data) (+ (cadr data) (node-height arg tree)))
 72 | ;                              child-w
 73 | ;                              (+ 1 row)
 74 | ;                              (- (length (node-args n)) 1)
 75 | ;                              tree)))
 76 | ;                   (list
 77 | ;                    (if VERTICAL (car data) (+ (car data) (utterance-w res)))
 78 | ;                    (if VERTICAL (+ (cadr data) (node-height arg tree)) (cadr data))
 79 | ;                    (if (null? res)
 80 | ;                     (caddr data)
 81 | ;                     (append
 82 | ;                      (caddr data)
 83 | ;                      (list res))))))
 84 | ;                 (list x y '())
 85 | ;                 (node-args n)))))))
 86 | ;       (utterance
 87 | ;        n
 88 | ;        x
 89 | ;        y
 90 | ;        (if VERTICAL w (max (box-width ((node-text-func n) n)) (apply + (map utterance-w children))))
 91 | ;        (node-height n tree)
 92 | ;        (box-width ((node-text-func n) n))
 93 | ;        (box-height ((node-text-func n) n))
 94 | ;        children
 95 | ;        (get-color n tree)))))))
 96 | ;
 97 | ;  (lambda (root x y tree)
 98 | ;   (let find-utterance ((root root) (x x) (y y) (tree tree))
 99 | ;    (with
100 | ;     ((if (or
101 | ;           (above-bottom-of-utterance?)
102 | ;           (utterance-is-closed?)
103 | ;           (has-no-children?)
104 | ;           (is-to-the-right-of-utterance?))
105 | ;       root
106 | ;       (pass-on-to-child)))
107 | ;   
108 | ;     (above-bottom-of-utterance? ()
109 | ;      (< (min-dim x y) (+ (utterance-min-dim root) (utterance-min-dim-span root))))
110 | ;   
111 | ;     (utterance-is-closed? ()
112 | ;      (closed? (utterance-node root) tree))
113 | ;           
114 | ;     (has-no-children? ()
115 | ;      (null? (node-args (utterance-node root))))
116 | ;   
117 | ;     (is-to-the-right-of-utterance? ()
118 | ;      (>= (maj-dim x y) (let ((baby (last (utterance-args root)))) (+ (utterance-maj-dim baby) (utterance-maj-dim-span baby)))))
119 | ;   
120 | ;     (pass-on-to-child ()
121 | ;      (ormap
122 | ;       (lambda (child)
123 | ;        (if (< (maj-dim x y) (+ (utterance-maj-dim child) (utterance-maj-dim-span child)))
124 | ;         (find-utterance child x y tree)
125 | ;         #f))
126 | ;       (utterance-args root))))))
127 | ;
128 | ;  (lambda (dir event)
129 | ;   (cond
130 | ;    ((eq? dir 'up)
131 | ;     (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))
132 | ;    ((eq? dir 'down)
133 | ;     (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
134 | ;    ((eq? dir 'left)
135 | ;     (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
136 | ;    ((eq? dir 'right)
137 | ;     (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))))))
138 | 
139 | 


--------------------------------------------------------------------------------
/visualizations/disk.phl:
--------------------------------------------------------------------------------
1 | #hash((0 . #s((parent-gnode gnode 2) 0 - (1 6 20 9) ())) (1 . #s((parent-gnode gnode 2) 1 - (2 3 4 5) ())) (2 . #s((terminal-gnode (1 #t) gnode 2) 1 require #t)) (3 . #s((terminal-gnode (1 #t) gnode 2) 3 sgl #t)) (4 . #s((terminal-gnode (1 #t) gnode 2) 4 sgl/gl #t)) (5 . #s((terminal-gnode (1 #t) gnode 2) 5 |"../core/common.rkt"| #t)) (6 . #s((parent-gnode gnode 2) 6 - (7 8) ())) (7 . #s((terminal-gnode (1 #t) gnode 2) 6 provide #t)) (8 . #s((terminal-gnode (1 #t) gnode 2) 8 visualization #t)) (9 . #s((parent-gnode gnode 2) 9 - (11 12 13) ())) (10 . #s((terminal-gnode (1 #t) gnode 2) 9 - #t)) (11 . #s((terminal-gnode (1 #t) gnode 2) 9 define #t)) (next-id . 696) (12 . #s((terminal-gnode (1 #t) gnode 2) 12 visualization #t)) (13 . #s((parent-gnode gnode 2) 13 - (14 131 19 110 123) (131 123 110 19))) (14 . #s((terminal-gnode (1 #t) gnode 2) 13 v11n #t)) (15 . #s((parent-gnode gnode 2) 15 - (132 133 139 145 150 152 671 168 173 175) (158))) (16 . #s((parent-gnode gnode 2) 16 - (56 92 691 692 98) (56 92 56))) (17 . #s((parent-gnode gnode 2) 17 - (337 112) (118 116 114 112))) (18 . #s((parent-gnode gnode 2) 18 - (130) (127 126))) (19 . #s((function-gnode variable-gnode 1 gnode 2) 19 utterance-maker 16 (99 109))) (20 . #s((parent-gnode gnode 2) 20 - (22 23 24 25 342) ())) (21 . #s((terminal-gnode (1 #t) gnode 2) 20 - #t)) (22 . #s((terminal-gnode (1 #t) gnode 2) 20 struct #t)) (23 . #s((terminal-gnode (1 #t) gnode 2) 23 disk-utterance #t)) (24 . #s((terminal-gnode (1 #t) gnode 2) 24 utterance #t)) (25 . #s((parent-gnode gnode 2) 25 - (26 27 28) ())) (26 . #s((terminal-gnode (1 #t) gnode 2) 25 thstart #t)) (27 . #s((terminal-gnode (1 #t) gnode 2) 27 thrange #t)) (28 . #s((terminal-gnode (1 #t) gnode 2) 28 r #t)) (29 . #s((parent-gnode gnode 2) 29 - (57 31 100 206 33 37 39) (329 39 37 33 31 106))) (30 . #s((terminal-gnode (1 #t) gnode 2) 30 - #t)) (31 . #s((variable-gnode gnode 2) 31 n 87)) (32 . #s((terminal-gnode (1 #t) gnode 2) 32 - #t)) (33 . #s((variable-gnode gnode 2) 33 thstart 88)) (34 . #s((terminal-gnode (1 #t) gnode 2) 34 thrange #t)) (35 . #s((terminal-gnode (1 #t) gnode 2) 35 r #t)) (36 . #s((terminal-gnode (1 #t) gnode 2) 36 - #t)) (37 . #s((variable-gnode gnode 2) 37 thrange 89)) (38 . #s((terminal-gnode (1 #t) gnode 2) 38 - #t)) (39 . #s((variable-gnode gnode 2) 39 r 90)) (40 . #s((parent-gnode gnode 2) 40 chilluns (41 54 46 43) (78 54))) (41 . #s((terminal-gnode (1 #t) gnode 2) 40 map #t)) (42 . #s((parent-gnode gnode 2) 42 - (56 332 63 70 82) (332 70))) (43 . #s((parent-gnode gnode 2) 43 - (44 31) ())) (44 . #s((terminal-gnode (1 #t) gnode 2) 43 node-args #t)) (45 . #s((terminal-gnode (1 #t) gnode 2) 45 n #t)) (46 . #s((parent-gnode gnode 2) 46 - (47 78 53) ())) (47 . #s((terminal-gnode (1 #t) gnode 2) 46 build-list #t)) (48 . #s((parent-gnode gnode 2) 48 - (49 50) ())) (49 . #s((terminal-gnode (1 #t) gnode 2) 48 length #t)) (50 . #s((parent-gnode gnode 2) 50 - (51 31) ())) (51 . #s((terminal-gnode (1 #t) gnode 2) 50 node-args #t)) (52 . #s((terminal-gnode (1 #t) gnode 2) 52 n #t)) (53 . #s((terminal-gnode (1 #t) gnode 2) 53 identity #t)) (54 . #s((function-gnode variable-gnode 1 gnode 2) 54 - 42 (327 333))) (55 . #s((terminal-gnode (1 #t) gnode 2) 42 - #t)) (56 . #s((function-gnode variable-gnode 1 gnode 2) 56 node->utterance 29 (87 88 89 90))) (57 . #s((terminal-gnode (1 #t) gnode 2) 29 disk-utterance #t)) (58 . #s((terminal-gnode (1 #t) gnode 2) 58 - #t)) (59 . #s((parent-gnode gnode 2) 59 - (60 61 62) ())) (60 . #s((terminal-gnode (1 #t) gnode 2) 59 * #t)) (61 . #s((terminal-gnode (1 #t) gnode 2) 61 i #t)) (62 . #s((terminal-gnode (1 #t) gnode 2) 62 - #t)) (63 . #s((parent-gnode gnode 2) 63 - (64 33 66) ())) (65 . #s((terminal-gnode (1 #t) gnode 2) 65 - #t)) (64 . #s((terminal-gnode (1 #t) gnode 2) 63 + #t)) (67 . #s((terminal-gnode (1 #t) gnode 2) 66 * #t)) (66 . #s((parent-gnode gnode 2) 66 - (67 326 70) (326))) (69 . #s((parent-gnode gnode 2) 69 - (71 37 78) ())) (68 . #s((terminal-gnode (1 #t) gnode 2) 68 i #t)) (71 . #s((terminal-gnode (1 #t) gnode 2) 69 / #t)) (70 . #s((variable-gnode gnode 2) 70 childrange 69)) (73 . #s((parent-gnode gnode 2) 73 - (74 75) ())) (72 . #s((terminal-gnode (1 #t) gnode 2) 72 - #t)) (75 . #s((parent-gnode gnode 2) 75 - (76 31) ())) (74 . #s((terminal-gnode (1 #t) gnode 2) 73 length #t)) (77 . #s((terminal-gnode (1 #t) gnode 2) 77 - #t)) (76 . #s((terminal-gnode (1 #t) gnode 2) 75 node-args #t)) (79 . #s((terminal-gnode (1 #t) gnode 2) 79 num #t)) (78 . #s((variable-gnode gnode 2) 78 numchildren 48)) (81 . #s((terminal-gnode (1 #t) gnode 2) 81 - #t)) (80 . #s((terminal-gnode (1 #t) gnode 2) 80 - #t)) (83 . #s((terminal-gnode (1 #t) gnode 2) 82 + #t)) (82 . #s((parent-gnode gnode 2) 82 - (83 39 85) ())) (85 . #s((terminal-gnode (1 #t) gnode 2) 85 1 #t)) (84 . #s((terminal-gnode (1 #t) gnode 2) 84 - #t)) (87 . #s((argument-gnode (1 #t) gnode 2) 87 arger #t)) (89 . #s((argument-gnode (1 #t) gnode 2) 89 arger #t)) (88 . #s((argument-gnode (1 #t) gnode 2) 88 arger #t)) (91 . #s((terminal-gnode (1 #t) gnode 2) 91 - #t)) (90 . #s((argument-gnode (1 #t) gnode 2) 90 arger #t)) (93 . #s((parent-gnode gnode 2) 93 - (455 456 457) ())) (92 . #s((variable-gnode gnode 2) 92 out-n 99)) (95 . #s((terminal-gnode (1 #t) gnode 2) 94 * #t)) (94 . #s((parent-gnode gnode 2) 94 - (95 96 97) ())) (97 . #s((terminal-gnode (1 #t) gnode 2) 97 pi #t)) (96 . #s((terminal-gnode (1 #t) gnode 2) 96 1/2 #t)) (99 . #s((argument-gnode (1 #t) gnode 2) 99 arger #t)) (98 . #s((terminal-gnode (1 #t) gnode 2) 98 1 #t)) (101 . #s((terminal-gnode (1 #t) gnode 2) 100 if #t)) (100 . #s((parent-gnode gnode 2) 100 - (101 102 107 40) ())) (103 . #s((terminal-gnode (1 #t) gnode 2) 102 closed? #t)) (102 . #s((parent-gnode gnode 2) 102 - (103 31 106) ())) (105 . #s((terminal-gnode (1 #t) gnode 2) 105 - #t)) (104 . #s((terminal-gnode (1 #t) gnode 2) 104 - #t)) (107 . #s((terminal-gnode (1 #t) gnode 2) 107 null #t)) (106 . #s((variable-gnode gnode 2) 106 tree 109)) (109 . #s((argument-gnode (1 #t) gnode 2) 109 arger #t)) (108 . #s((terminal-gnode (1 #t) gnode 2) 108 - #t)) (111 . #s((terminal-gnode (1 #t) gnode 2) 17 - #t)) (110 . #s((function-gnode variable-gnode 1 gnode 2) 110 utterance-finder 17 (119 120 121 122))) (113 . #s((terminal-gnode (1 #t) gnode 2) 113 - #t)) (112 . #s((variable-gnode gnode 2) 112 root 119)) (115 . #s((terminal-gnode (1 #t) gnode 2) 115 - #t)) (114 . #s((variable-gnode gnode 2) 114 x 120)) (117 . #s((terminal-gnode (1 #t) gnode 2) 117 - #t)) (116 . #s((variable-gnode gnode 2) 116 y 121)) (119 . #s((argument-gnode (1 #t) gnode 2) 119 arger #t)) (118 . #s((variable-gnode gnode 2) 118 tree 122)) (121 . #s((argument-gnode (1 #t) gnode 2) 121 arger #t)) (120 . #s((argument-gnode (1 #t) gnode 2) 120 arger #t)) (123 . #s((function-gnode variable-gnode 1 gnode 2) 123 scroller 18 (128 129))) (122 . #s((argument-gnode (1 #t) gnode 2) 122 arger #t)) (125 . #s((terminal-gnode (1 #t) gnode 2) 125 - #t)) (124 . #s((terminal-gnode (1 #t) gnode 2) 18 - #t)) (127 . #s((variable-gnode gnode 2) 127 event 129)) (126 . #s((variable-gnode gnode 2) 126 dir 128)) (130 . #s((terminal-gnode (1 #t) gnode 2) 18 null #t)) (131 . #s((function-gnode variable-gnode 1 gnode 2) 131 painter 15 (159))) (128 . #s((argument-gnode (1 #t) gnode 2) 128 arger #t)) (129 . #s((argument-gnode (1 #t) gnode 2) 129 arger #t)) (134 . #s((terminal-gnode (1 #t) gnode 2) 133 apply #t)) (135 . #s((terminal-gnode (1 #t) gnode 2) 135 gl-scissor #t)) (132 . #s((terminal-gnode (1 #t) gnode 2) 15 begin #t)) (133 . #s((parent-gnode gnode 2) 133 - (134 135 136) ())) (138 . #s((terminal-gnode (1 #t) gnode 2) 138 tree #t)) (139 . #s((parent-gnode gnode 2) 139 - (140 141 142) ())) (136 . #s((parent-gnode gnode 2) 136 - (137 158) ())) (137 . #s((terminal-gnode (1 #t) gnode 2) 136 whole-tree-dim #t)) (142 . #s((parent-gnode gnode 2) 142 - (143 158) ())) (143 . #s((terminal-gnode (1 #t) gnode 2) 142 whole-tree-dim #t)) (140 . #s((terminal-gnode (1 #t) gnode 2) 139 apply #t)) (141 . #s((terminal-gnode (1 #t) gnode 2) 141 gl-viewport #t)) (146 . #s((terminal-gnode (1 #t) gnode 2) 145 gl-matrix-mode #t)) (147 . #s((parent-gnode gnode 2) 147 - (148 149) ())) (144 . #s((terminal-gnode (1 #t) gnode 2) 144 tree #t)) (145 . #s((parent-gnode gnode 2) 145 - (146 147) ())) (150 . #s((parent-gnode gnode 2) 150 - (151) ())) (151 . #s((terminal-gnode (1 #t) gnode 2) 150 gl-load-identity #t)) (148 . #s((terminal-gnode (1 #t) gnode 2) 147 quote #t)) (149 . #s((terminal-gnode (1 #t) gnode 2) 149 projection #t)) (154 . #s((terminal-gnode (1 #t) gnode 2) 154 0 #t)) (155 . #s((parent-gnode gnode 2) 155 - (156 158) ())) (152 . #s((parent-gnode gnode 2) 152 - (153 154 155 160 165 166 167) ())) (153 . #s((terminal-gnode (1 #t) gnode 2) 152 gl-frustum #t)) (158 . #s((variable-gnode gnode 2) 158 tree 159)) (159 . #s((argument-gnode (1 #t) gnode 2) 159 arger #t)) (156 . #s((terminal-gnode (1 #t) gnode 2) 155 whole-tree-w #t)) (157 . #s((terminal-gnode (1 #t) gnode 2) 157 tree #t)) (162 . #s((parent-gnode gnode 2) 162 - (163 158) ())) (163 . #s((terminal-gnode (1 #t) gnode 2) 162 whole-tree-h #t)) (160 . #s((parent-gnode gnode 2) 160 - (161 162) ())) (161 . #s((terminal-gnode (1 #t) gnode 2) 160 - #t)) (166 . #s((terminal-gnode (1 #t) gnode 2) 166 1 #t)) (167 . #s((terminal-gnode (1 #t) gnode 2) 167 2 #t)) (164 . #s((terminal-gnode (1 #t) gnode 2) 164 tree #t)) (165 . #s((terminal-gnode (1 #t) gnode 2) 165 0 #t)) (170 . #s((parent-gnode gnode 2) 170 - (171 172) ())) (171 . #s((terminal-gnode (1 #t) gnode 2) 170 quote #t)) (168 . #s((parent-gnode gnode 2) 168 - (169 170) ())) (169 . #s((terminal-gnode (1 #t) gnode 2) 168 gl-matrix-mode #t)) (174 . #s((terminal-gnode (1 #t) gnode 2) 173 gl-load-identity #t)) (175 . #s((parent-gnode gnode 2) 175 - (177 178) (177))) (172 . #s((terminal-gnode (1 #t) gnode 2) 172 modelview #t)) (173 . #s((parent-gnode gnode 2) 173 - (174) ())) (178 . #s((parent-gnode gnode 2) 178 - (179 158) ())) (179 . #s((terminal-gnode (1 #t) gnode 2) 178 whole-tree-utterance-tree #t)) (176 . #s((parent-gnode gnode 2) 176 - (181 183 459 185) (600 477 471 458 192))) (177 . #s((function-gnode variable-gnode 1 gnode 2) 177 utterance-paint 176 (193))) (182 . #s((terminal-gnode (1 #t) gnode 2) 181 - #t)) (183 . #s((parent-gnode gnode 2) 183 - (186 334 194 197 200) (186))) (180 . #s((terminal-gnode (1 #t) gnode 2) 180 - #t)) (181 . #s((terminal-gnode (1 #t) gnode 2) 181 begin #t)) (186 . #s((function-gnode variable-gnode 1 gnode 2) 186 draw-wedge 184 (219 288 295 296))) (187 . #s((terminal-gnode (1 #t) gnode 2) 185 map #t)) (184 . #s((parent-gnode gnode 2) 184 - (210 211 233 243 644 238) (307 630 629 258 292 286 279 218))) (185 . #s((parent-gnode gnode 2) 185 - (187 177 189) ())) (190 . #s((terminal-gnode (1 #t) gnode 2) 189 utterance-args #t)) (191 . #s((terminal-gnode (1 #t) gnode 2) 191 u #t)) (188 . #s((terminal-gnode (1 #t) gnode 2) 188 - #t)) (189 . #s((parent-gnode gnode 2) 189 - (190 192) ())) (195 . #s((terminal-gnode (1 #t) gnode 2) 194 disk-utterance-thstart #t)) (194 . #s((parent-gnode gnode 2) 194 - (195 192) ())) (193 . #s((argument-gnode (1 #t) gnode 2) 193 arger #t)) (192 . #s((variable-gnode gnode 2) 192 u 193)) (199 . #s((terminal-gnode (1 #t) gnode 2) 199 - #t)) (198 . #s((terminal-gnode (1 #t) gnode 2) 197 disk-utterance-thrange #t)) (197 . #s((parent-gnode gnode 2) 197 - (198 192) ())) (196 . #s((terminal-gnode (1 #t) gnode 2) 196 - #t)) (203 . #s((parent-gnode gnode 2) 203 - (204 192) ())) (202 . #s((terminal-gnode (1 #t) gnode 2) 202 - #t)) (201 . #s((terminal-gnode (1 #t) gnode 2) 200 disk-utterance-r #t)) (200 . #s((parent-gnode gnode 2) 200 - (201 192) ())) (207 . #s((terminal-gnode (1 #t) gnode 2) 206 get-color #t)) (206 . #s((parent-gnode gnode 2) 206 - (207 31 106) ())) (205 . #s((terminal-gnode (1 #t) gnode 2) 205 - #t)) (204 . #s((terminal-gnode (1 #t) gnode 2) 203 utterance-clr #t)) (211 . #s((parent-gnode gnode 2) 211 - (212 213 221 227) ())) (210 . #s((terminal-gnode (1 #t) gnode 2) 184 begin #t)) (209 . #s((terminal-gnode (1 #t) gnode 2) 209 - #t)) (208 . #s((terminal-gnode (1 #t) gnode 2) 208 - #t)) (215 . #s((parent-gnode gnode 2) 215 - (216 218) ())) (214 . #s((terminal-gnode (1 #t) gnode 2) 213 / #t)) (213 . #s((parent-gnode gnode 2) 213 - (214 215 220) ())) (212 . #s((terminal-gnode (1 #t) gnode 2) 211 gl-color #t)) (219 . #s((argument-gnode (1 #t) gnode 2) 219 arger #t)) (218 . #s((variable-gnode gnode 2) 218 clr 219)) (217 . #s((terminal-gnode (1 #t) gnode 2) 217 - #t)) (216 . #s((terminal-gnode (1 #t) gnode 2) 215 car #t)) (223 . #s((parent-gnode gnode 2) 223 - (224 218) ())) (222 . #s((terminal-gnode (1 #t) gnode 2) 221 / #t)) (221 . #s((parent-gnode gnode 2) 221 - (222 223 226) ())) (220 . #s((terminal-gnode (1 #t) gnode 2) 220 255 #t)) (227 . #s((parent-gnode gnode 2) 227 - (228 229 232) ())) (226 . #s((terminal-gnode (1 #t) gnode 2) 226 255 #t)) (225 . #s((terminal-gnode (1 #t) gnode 2) 225 - #t)) (224 . #s((terminal-gnode (1 #t) gnode 2) 223 cadr #t)) (231 . #s((terminal-gnode (1 #t) gnode 2) 231 - #t)) (230 . #s((terminal-gnode (1 #t) gnode 2) 229 caddr #t)) (229 . #s((parent-gnode gnode 2) 229 - (230 218) ())) (228 . #s((terminal-gnode (1 #t) gnode 2) 227 / #t)) (235 . #s((parent-gnode gnode 2) 235 - (236 237) ())) (234 . #s((terminal-gnode (1 #t) gnode 2) 233 gl-begin #t)) (233 . #s((parent-gnode gnode 2) 233 - (234 235) ())) (232 . #s((terminal-gnode (1 #t) gnode 2) 232 255 #t)) (239 . #s((terminal-gnode (1 #t) gnode 2) 238 gl-end #t)) (238 . #s((parent-gnode gnode 2) 238 - (239) ())) (237 . #s((terminal-gnode (1 #t) gnode 2) 237 polygon #t)) (236 . #s((terminal-gnode (1 #t) gnode 2) 235 quote #t)) (243 . #s((parent-gnode gnode 2) 243 - (244 258 638 641) ())) (242 . #s((terminal-gnode (1 #t) gnode 2) 242 lines #t)) (241 . #s((terminal-gnode (1 #t) gnode 2) 240 quote #t)) (240 . #s((parent-gnode gnode 2) 240 - (241 242) ())) (247 . #s((terminal-gnode (1 #t) gnode 2) 247 - #t)) (246 . #s((parent-gnode gnode 2) 246 - (248 267 254) ())) (245 . #s((parent-gnode gnode 2) 245 - (259 453) (265))) (244 . #s((terminal-gnode (1 #t) gnode 2) 243 for-each #t)) (251 . #s((terminal-gnode (1 #t) gnode 2) 251 - #t)) (250 . #s((terminal-gnode (1 #t) gnode 2) 249 * #t)) (249 . #s((parent-gnode gnode 2) 249 - (250 252 253) (252))) (248 . #s((terminal-gnode (1 #t) gnode 2) 246 build-list #t)) (255 . #s((parent-gnode gnode 2) 255 - (256 249) ())) (254 . #s((parent-gnode gnode 2) 254 - (268 269 270) ())) (253 . #s((terminal-gnode (1 #t) gnode 2) 253 100 #t)) (252 . #s((variable-gnode gnode 2) 252 thrange 251)) (260 . #s((parent-gnode gnode 2) 260 - (261 299 300 298) (300 299))) (261 . #s((terminal-gnode (1 #t) gnode 2) 260 gl-vertex #t)) (262 . #s((terminal-gnode (1 #t) gnode 2) 262 - #t)) (263 . #s((parent-gnode gnode 2) 263 - (264) ())) (256 . #s((terminal-gnode (1 #t) gnode 2) 255 round #t)) (257 . #s((terminal-gnode (1 #t) gnode 2) 257 - #t)) (258 . #s((function-gnode variable-gnode 1 gnode 2) 258 --- 245 (301 302))) (259 . #s((terminal-gnode (1 #t) gnode 2) 245 begin #t)) (268 . #s((terminal-gnode (1 #t) gnode 2) 254 curryr #t)) (269 . #s((terminal-gnode (1 #t) gnode 2) 269 / #t)) (270 . #s((terminal-gnode (1 #t) gnode 2) 270 500 #t)) (271 . #s((parent-gnode gnode 2) 271 - (272 274 307) (274))) (264 . #s((terminal-gnode (1 #t) gnode 2) 263 - #t)) (265 . #s((function-gnode variable-gnode 1 gnode 2) 265 lam 260 ())) (266 . #s((terminal-gnode (1 #t) gnode 2) 266 - #t)) (267 . #s((terminal-gnode (1 #t) gnode 2) 267 501 #t)) (277 . #s((terminal-gnode (1 #t) gnode 2) 273 * #t)) (278 . #s((terminal-gnode (1 #t) gnode 2) 278 - #t)) (279 . #s((variable-gnode gnode 2) 279 r 296)) (272 . #s((terminal-gnode (1 #t) gnode 2) 271 map #t)) (273 . #s((parent-gnode gnode 2) 273 - (471 635 513) (635 293))) (274 . #s((function-gnode variable-gnode 1 gnode 2) 274 - 273 (294))) (285 . #s((terminal-gnode (1 #t) gnode 2) 285 - #t)) (286 . #s((variable-gnode gnode 2) 286 thstart 288)) (287 . #s((parent-gnode gnode 2) 287 - (289 293 292) ())) (280 . #s((parent-gnode gnode 2) 280 - (281 282) ())) (281 . #s((terminal-gnode (1 #t) gnode 2) 280 cos #t)) (282 . #s((parent-gnode gnode 2) 282 - (283 286 287) ())) (283 . #s((terminal-gnode (1 #t) gnode 2) 282 + #t)) (292 . #s((variable-gnode gnode 2) 292 thrange 295)) (293 . #s((variable-gnode gnode 2) 293 incr 294)) (294 . #s((argument-gnode (1 #t) gnode 2) 294 arger #t)) (295 . #s((argument-gnode (1 #t) gnode 2) 295 arger #t)) (288 . #s((argument-gnode (1 #t) gnode 2) 288 arger #t)) (289 . #s((terminal-gnode (1 #t) gnode 2) 287 * #t)) (290 . #s((terminal-gnode (1 #t) gnode 2) 290 x #t)) (291 . #s((terminal-gnode (1 #t) gnode 2) 291 - #t)) (300 . #s((variable-gnode gnode 2) 300 y 302)) (301 . #s((argument-gnode (1 #t) gnode 2) 301 arger #t)) (302 . #s((argument-gnode (1 #t) gnode 2) 302 arger #t)) (296 . #s((argument-gnode (1 #t) gnode 2) 296 arger #t)) (297 . #s((terminal-gnode (1 #t) gnode 2) 297 - #t)) (298 . #s((terminal-gnode (1 #t) gnode 2) 298 |-1.01| #t)) (299 . #s((variable-gnode gnode 2) 299 x 301)) (308 . #s((terminal-gnode (1 #t) gnode 2) 308 - #t)) (310 . #s((function-gnode variable-gnode 1 gnode 2) 310 - 306 (323))) (311 . #s((terminal-gnode (1 #t) gnode 2) 306 * #t)) (304 . #s((parent-gnode gnode 2) 304 - (305 310 307) (310))) (305 . #s((terminal-gnode (1 #t) gnode 2) 304 map #t)) (306 . #s((parent-gnode gnode 2) 306 - (477 633 522) (633 321))) (307 . #s((variable-gnode gnode 2) 307 increments 246)) (316 . #s((terminal-gnode (1 #t) gnode 2) 315 + #t)) (317 . #s((terminal-gnode (1 #t) gnode 2) 317 - #t)) (318 . #s((parent-gnode gnode 2) 318 - (319 321 292) ())) (319 . #s((terminal-gnode (1 #t) gnode 2) 318 * #t)) (312 . #s((terminal-gnode (1 #t) gnode 2) 312 - #t)) (313 . #s((parent-gnode gnode 2) 313 - (314 315) ())) (314 . #s((terminal-gnode (1 #t) gnode 2) 313 sin #t)) (315 . #s((parent-gnode gnode 2) 315 - (316 286 318) ())) (325 . #s((terminal-gnode (1 #t) gnode 2) 325 20 #t)) (324 . #s((terminal-gnode (1 #t) gnode 2) 324 20 #t)) (327 . #s((argument-gnode (1 #t) gnode 2) 327 arger #t)) (326 . #s((variable-gnode gnode 2) 326 i 327)) (321 . #s((variable-gnode gnode 2) 321 incr 323)) (320 . #s((terminal-gnode (1 #t) gnode 2) 320 - #t)) (323 . #s((argument-gnode (1 #t) gnode 2) 323 arger #t)) (322 . #s((terminal-gnode (1 #t) gnode 2) 322 - #t)) (333 . #s((argument-gnode (1 #t) gnode 2) 333 arger #t)) (332 . #s((variable-gnode gnode 2) 332 in-n 333)) (335 . #s((terminal-gnode (1 #t) gnode 2) 334 cdr #t)) (334 . #s((parent-gnode gnode 2) 334 - (335 203) ())) (329 . #s((variable-gnode gnode 2) 329 in-n 328)) (328 . #s((terminal-gnode (1 #t) gnode 2) 328 - #t)) (331 . #s((terminal-gnode (1 #t) gnode 2) 331 - #t)) (330 . #s((terminal-gnode (1 #t) gnode 2) 330 - #t)) (341 . #s((terminal-gnode (1 #t) gnode 2) 341 - #t)) (340 . #s((terminal-gnode (1 #t) gnode 2) 340 |"yo"| #t)) (343 . #s((parent-gnode gnode 2) 343 - (344 345 350 351 352 353) ())) (342 . #s((terminal-gnode (1 #t) gnode 2) 342 |#:transparent| #t)) (337 . #s((terminal-gnode (1 #t) gnode 2) 17 identity #t)) (336 . #s((terminal-gnode (1 #t) gnode 2) 336 - #t)) (339 . #s((terminal-gnode (1 #t) gnode 2) 338 displayln #t)) (338 . #s((parent-gnode gnode 2) 338 - (339 192) ())) (349 . #s((terminal-gnode (1 #t) gnode 2) 349 - #t)) (348 . #s((terminal-gnode (1 #t) gnode 2) 347 utterance-clr #t)) (351 . #s((terminal-gnode (1 #t) gnode 2) 351 0 #t)) (350 . #s((terminal-gnode (1 #t) gnode 2) 350 0 #t)) (345 . #s((parent-gnode gnode 2) 345 - (346 347) ())) (344 . #s((terminal-gnode (1 #t) gnode 2) 343 draw-rectangle #t)) (347 . #s((parent-gnode gnode 2) 347 - (348 192) ())) (346 . #s((terminal-gnode (1 #t) gnode 2) 345 cdr #t)) (357 . #s((terminal-gnode (1 #t) gnode 2) 356 disk-utterance-r #t)) (356 . #s((parent-gnode gnode 2) 356 - (357 192) ())) (359 . #s((parent-gnode gnode 2) 359 - (360 498 502 419) ())) (358 . #s((terminal-gnode (1 #t) gnode 2) 358 - #t)) (353 . #s((terminal-gnode (1 #t) gnode 2) 353 100 #t)) (352 . #s((parent-gnode gnode 2) 352 - (354 355 356) ())) (355 . #s((terminal-gnode (1 #t) gnode 2) 355 100 #t)) (354 . #s((terminal-gnode (1 #t) gnode 2) 352 * #t)) (365 . #s((terminal-gnode (1 #t) gnode 2) 364 cos #t)) (364 . #s((parent-gnode gnode 2) 364 - (365 286) ())) (367 . #s((terminal-gnode (1 #t) gnode 2) 366 + #t)) (366 . #s((parent-gnode gnode 2) 366 - (286 369) ())) (361 . #s((terminal-gnode (1 #t) gnode 2) 361 * #t)) (360 . #s((terminal-gnode (1 #t) gnode 2) 359 gl-vertex #t)) (363 . #s((terminal-gnode (1 #t) gnode 2) 363 r #t)) (362 . #s((terminal-gnode (1 #t) gnode 2) 362 20 #t)) (373 . #s((parent-gnode gnode 2) 373 - (374 458 279 377) ())) (372 . #s((terminal-gnode (1 #t) gnode 2) 372 - #t)) (375 . #s((terminal-gnode (1 #t) gnode 2) 375 20 #t)) (374 . #s((terminal-gnode (1 #t) gnode 2) 373 * #t)) (369 . #s((parent-gnode gnode 2) 369 - (370 371) ())) (368 . #s((terminal-gnode (1 #t) gnode 2) 368 - #t)) (371 . #s((terminal-gnode (1 #t) gnode 2) 371 - #t)) (370 . #s((terminal-gnode (1 #t) gnode 2) 369 * #t)) (381 . #s((terminal-gnode (1 #t) gnode 2) 380 * #t)) (380 . #s((parent-gnode gnode 2) 380 - (381 458 279 384) ())) (383 . #s((terminal-gnode (1 #t) gnode 2) 383 - #t)) (382 . #s((terminal-gnode (1 #t) gnode 2) 382 20 #t)) (377 . #s((parent-gnode gnode 2) 377 - (378 286) ())) (376 . #s((terminal-gnode (1 #t) gnode 2) 376 - #t)) (379 . #s((terminal-gnode (1 #t) gnode 2) 379 - #t)) (378 . #s((terminal-gnode (1 #t) gnode 2) 377 cos #t)) (390 . #s((terminal-gnode (1 #t) gnode 2) 389 * #t)) (391 . #s((terminal-gnode (1 #t) gnode 2) 391 200 #t)) (388 . #s((terminal-gnode (1 #t) gnode 2) 387 gl-vertex #t)) (389 . #s((parent-gnode gnode 2) 389 - (390 458 473 393) (473))) (386 . #s((terminal-gnode (1 #t) gnode 2) 386 - #t)) (387 . #s((parent-gnode gnode 2) 387 - (388 484 491 420) ())) (384 . #s((parent-gnode gnode 2) 384 - (385 286) ())) (385 . #s((terminal-gnode (1 #t) gnode 2) 384 sin #t)) (398 . #s((terminal-gnode (1 #t) gnode 2) 398 - #t)) (399 . #s((parent-gnode gnode 2) 399 - (400 458 479 403) (479))) (396 . #s((terminal-gnode (1 #t) gnode 2) 395 + #t)) (397 . #s((terminal-gnode (1 #t) gnode 2) 397 - #t)) (394 . #s((terminal-gnode (1 #t) gnode 2) 393 cos #t)) (395 . #s((parent-gnode gnode 2) 395 - (396 286 292) ())) (392 . #s((terminal-gnode (1 #t) gnode 2) 392 - #t)) (393 . #s((parent-gnode gnode 2) 393 - (394 476) ())) (406 . #s((terminal-gnode (1 #t) gnode 2) 405 + #t)) (407 . #s((terminal-gnode (1 #t) gnode 2) 407 - #t)) (404 . #s((terminal-gnode (1 #t) gnode 2) 403 sin #t)) (405 . #s((parent-gnode gnode 2) 405 - (406 286 292) ())) (402 . #s((terminal-gnode (1 #t) gnode 2) 402 - #t)) (403 . #s((parent-gnode gnode 2) 403 - (404 481) (481))) (400 . #s((terminal-gnode (1 #t) gnode 2) 399 * #t)) (401 . #s((terminal-gnode (1 #t) gnode 2) 401 20 #t)) (414 . #s((parent-gnode gnode 2) 414 - (415 416 417) ())) (415 . #s((terminal-gnode (1 #t) gnode 2) 414 gl-vertex #t)) (412 . #s((terminal-gnode (1 #t) gnode 2) 411 quote #t)) (413 . #s((terminal-gnode (1 #t) gnode 2) 413 - #t)) (410 . #s((terminal-gnode (1 #t) gnode 2) 409 identity #t)) (411 . #s((parent-gnode gnode 2) 411 - (412 343) ())) (408 . #s((terminal-gnode (1 #t) gnode 2) 408 - #t)) (409 . #s((parent-gnode gnode 2) 409 - (410 411) ())) (422 . #s((terminal-gnode (1 #t) gnode 2) 421 gl-begin #t)) (423 . #s((parent-gnode gnode 2) 423 - (424 425) ())) (420 . #s((terminal-gnode (1 #t) gnode 2) 420 |-1.1| #t)) (421 . #s((parent-gnode gnode 2) 421 - (422 423) ())) (419 . #s((terminal-gnode (1 #t) gnode 2) 419 |-1.1| #t)) (416 . #s((terminal-gnode (1 #t) gnode 2) 416 0 #t)) (417 . #s((terminal-gnode (1 #t) gnode 2) 417 0 #t)) (430 . #s((terminal-gnode (1 #t) gnode 2) 430 |-1.1| #t)) (431 . #s((parent-gnode gnode 2) 431 - (432 433 434 435) ())) (428 . #s((terminal-gnode (1 #t) gnode 2) 428 0 #t)) (429 . #s((terminal-gnode (1 #t) gnode 2) 429 0 #t)) (426 . #s((parent-gnode gnode 2) 426 - (427 428 429 430) ())) (427 . #s((terminal-gnode (1 #t) gnode 2) 426 gl-vertex #t)) (424 . #s((terminal-gnode (1 #t) gnode 2) 423 quote #t)) (425 . #s((terminal-gnode (1 #t) gnode 2) 425 polygon #t)) (438 . #s((terminal-gnode (1 #t) gnode 2) 438 100 #t)) (439 . #s((terminal-gnode (1 #t) gnode 2) 439 |-100| #t)) (436 . #s((parent-gnode gnode 2) 436 - (437 438 439 440) ())) (437 . #s((terminal-gnode (1 #t) gnode 2) 436 gl-vertex #t)) (434 . #s((terminal-gnode (1 #t) gnode 2) 434 0 #t)) (435 . #s((terminal-gnode (1 #t) gnode 2) 435 |-1.1| #t)) (432 . #s((terminal-gnode (1 #t) gnode 2) 431 gl-vertex #t)) (433 . #s((terminal-gnode (1 #t) gnode 2) 433 100 #t)) (446 . #s((parent-gnode gnode 2) 446 - (447) ())) (447 . #s((terminal-gnode (1 #t) gnode 2) 446 gl-end #t)) (444 . #s((terminal-gnode (1 #t) gnode 2) 444 |-100| #t)) (445 . #s((terminal-gnode (1 #t) gnode 2) 445 |-1.1| #t)) (442 . #s((terminal-gnode (1 #t) gnode 2) 441 gl-vertex #t)) (443 . #s((terminal-gnode (1 #t) gnode 2) 443 0 #t)) (440 . #s((terminal-gnode (1 #t) gnode 2) 440 |-1.1| #t)) (441 . #s((parent-gnode gnode 2) 441 - (442 443 444 445) ())) (455 . #s((terminal-gnode (1 #t) gnode 2) 93 * #t)) (454 . #s((terminal-gnode (1 #t) gnode 2) 453 - #t)) (453 . #s((parent-gnode gnode 2) 453 - (265) ())) (452 . #s((terminal-gnode (1 #t) gnode 2) 452 |-1.1| #t)) (451 . #s((terminal-gnode (1 #t) gnode 2) 451 |-50| #t)) (450 . #s((terminal-gnode (1 #t) gnode 2) 450 150 #t)) (449 . #s((terminal-gnode (1 #t) gnode 2) 448 gl-vertex #t)) (448 . #s((parent-gnode gnode 2) 448 - (449 450 451 452) ())) (463 . #s((parent-gnode gnode 2) 463 - (464 465) ())) (462 . #s((variable-gnode gnode 2) 462 text 461)) (461 . #s((parent-gnode gnode 2) 461 - (463 468) ())) (460 . #s((terminal-gnode (1 #t) gnode 2) 459 draw-text #t)) (459 . #s((parent-gnode gnode 2) 459 - (460 462 529 586 539 592) (462))) (458 . #s((variable-gnode gnode 2) 458 radi 391)) (457 . #s((terminal-gnode (1 #t) gnode 2) 457 pi #t)) (456 . #s((terminal-gnode (1 #t) gnode 2) 456 3/2 #t)) (471 . #s((function-gnode variable-gnode 1 gnode 2) 471 get-x 389 (475 476))) (470 . #s((terminal-gnode (1 #t) gnode 2) 470 - #t)) (469 . #s((terminal-gnode (1 #t) gnode 2) 468 utterance-node #t)) (468 . #s((parent-gnode gnode 2) 468 - (469 192) ())) (467 . #s((terminal-gnode (1 #t) gnode 2) 467 - #t)) (466 . #s((terminal-gnode (1 #t) gnode 2) 465 utterance-node #t)) (465 . #s((parent-gnode gnode 2) 465 - (466 192) ())) (464 . #s((terminal-gnode (1 #t) gnode 2) 463 node-text-func #t)) (479 . #s((variable-gnode gnode 2) 479 rr 482)) (478 . #s((terminal-gnode (1 #t) gnode 2) 478 - #t)) (477 . #s((function-gnode variable-gnode 1 gnode 2) 477 get-y 399 (482 483))) (476 . #s((argument-gnode (1 #t) gnode 2) 476 arger #t)) (475 . #s((argument-gnode (1 #t) gnode 2) 475 arger #t)) (474 . #s((terminal-gnode (1 #t) gnode 2) 474 theta #t)) (473 . #s((variable-gnode gnode 2) 473 rr 475)) (472 . #s((terminal-gnode (1 #t) gnode 2) 472 - #t)) (487 . #s((parent-gnode gnode 2) 487 - (488 286 292) ())) (486 . #s((terminal-gnode (1 #t) gnode 2) 486 - #t)) (485 . #s((terminal-gnode (1 #t) gnode 2) 484 - #t)) (484 . #s((parent-gnode gnode 2) 484 - (471 279 487) ())) (483 . #s((argument-gnode (1 #t) gnode 2) 483 arger #t)) (482 . #s((argument-gnode (1 #t) gnode 2) 482 arger #t)) (481 . #s((variable-gnode gnode 2) 481 theta 483)) (480 . #s((terminal-gnode (1 #t) gnode 2) 480 - #t)) (495 . #s((terminal-gnode (1 #t) gnode 2) 494 + #t)) (494 . #s((parent-gnode gnode 2) 494 - (495 286 292) ())) (493 . #s((terminal-gnode (1 #t) gnode 2) 493 - #t)) (492 . #s((terminal-gnode (1 #t) gnode 2) 491 - #t)) (491 . #s((parent-gnode gnode 2) 491 - (477 279 494) ())) (490 . #s((terminal-gnode (1 #t) gnode 2) 490 - #t)) (489 . #s((terminal-gnode (1 #t) gnode 2) 489 - #t)) (488 . #s((terminal-gnode (1 #t) gnode 2) 487 + #t)) (503 . #s((terminal-gnode (1 #t) gnode 2) 502 - #t)) (502 . #s((parent-gnode gnode 2) 502 - (477 279 286) ())) (501 . #s((terminal-gnode (1 #t) gnode 2) 501 - #t)) (500 . #s((terminal-gnode (1 #t) gnode 2) 500 - #t)) (499 . #s((terminal-gnode (1 #t) gnode 2) 498 get-x #t)) (498 . #s((parent-gnode gnode 2) 498 - (471 279 286) ())) (497 . #s((terminal-gnode (1 #t) gnode 2) 497 - #t)) (496 . #s((terminal-gnode (1 #t) gnode 2) 496 - #t)) (510 . #s((terminal-gnode (1 #t) gnode 2) 510 - #t)) (509 . #s((terminal-gnode (1 #t) gnode 2) 509 - #t)) (508 . #s((terminal-gnode (1 #t) gnode 2) 508 - #t)) (506 . #s((terminal-gnode (1 #t) gnode 2) 506 - #t)) (505 . #s((terminal-gnode (1 #t) gnode 2) 505 - #t)) (504 . #s((terminal-gnode (1 #t) gnode 2) 504 - #t)) (520 . #s((terminal-gnode (1 #t) gnode 2) 520 - #t)) (521 . #s((terminal-gnode (1 #t) gnode 2) 521 - #t)) (522 . #s((parent-gnode gnode 2) 522 - (523 286 525) ())) (523 . #s((terminal-gnode (1 #t) gnode 2) 522 + #t)) (524 . #s((terminal-gnode (1 #t) gnode 2) 524 - #t)) (525 . #s((parent-gnode gnode 2) 525 - (526 321 292) ())) (526 . #s((terminal-gnode (1 #t) gnode 2) 525 * #t)) (527 . #s((terminal-gnode (1 #t) gnode 2) 527 - #t)) (513 . #s((parent-gnode gnode 2) 513 - (514 286 516) ())) (514 . #s((terminal-gnode (1 #t) gnode 2) 513 + #t)) (515 . #s((terminal-gnode (1 #t) gnode 2) 515 - #t)) (516 . #s((parent-gnode gnode 2) 516 - (517 293 292) ())) (517 . #s((terminal-gnode (1 #t) gnode 2) 516 * #t)) (518 . #s((terminal-gnode (1 #t) gnode 2) 518 - #t)) (519 . #s((terminal-gnode (1 #t) gnode 2) 519 - #t)) (536 . #s((parent-gnode gnode 2) 536 - (537 192) ())) (537 . #s((terminal-gnode (1 #t) gnode 2) 536 disk-utterance-r #t)) (538 . #s((terminal-gnode (1 #t) gnode 2) 538 - #t)) (539 . #s((parent-gnode gnode 2) 539 - (540 541) ())) (540 . #s((terminal-gnode (1 #t) gnode 2) 539 car #t)) (541 . #s((parent-gnode gnode 2) 541 - (542 192) ())) (542 . #s((terminal-gnode (1 #t) gnode 2) 541 utterance-clr #t)) (543 . #s((terminal-gnode (1 #t) gnode 2) 543 - #t)) (528 . #s((terminal-gnode (1 #t) gnode 2) 528 - #t)) (529 . #s((parent-gnode gnode 2) 529 - (471 665 600) ())) (530 . #s((terminal-gnode (1 #t) gnode 2) 529 get-x #t)) (531 . #s((parent-gnode gnode 2) 531 - (532 192) ())) (532 . #s((terminal-gnode (1 #t) gnode 2) 531 disk-utterance-r #t)) (533 . #s((terminal-gnode (1 #t) gnode 2) 533 - #t)) (534 . #s((parent-gnode gnode 2) 534 - (477 668 600) ())) (535 . #s((terminal-gnode (1 #t) gnode 2) 534 - #t)) (552 . #s((terminal-gnode (1 #t) gnode 2) 551 disk-utterance-thstart #t)) (553 . #s((terminal-gnode (1 #t) gnode 2) 553 - #t)) (554 . #s((parent-gnode gnode 2) 554 - (555 462 556) ())) (555 . #s((terminal-gnode (1 #t) gnode 2) 554 begin #t)) (556 . #s((terminal-gnode (1 #t) gnode 2) 556 |"test"| #t)) (559 . #s((parent-gnode gnode 2) 559 - (560 561 564) ())) (544 . #s((parent-gnode gnode 2) 544 - (545 192) ())) (545 . #s((terminal-gnode (1 #t) gnode 2) 544 disk-utterance-thstart #t)) (546 . #s((terminal-gnode (1 #t) gnode 2) 546 - #t)) (547 . #s((parent-gnode gnode 2) 547 - (548 192) ())) (548 . #s((terminal-gnode (1 #t) gnode 2) 547 disk-utterance-thrange #t)) (549 . #s((terminal-gnode (1 #t) gnode 2) 549 - #t)) (550 . #s((terminal-gnode (1 #t) gnode 2) 550 - #t)) (551 . #s((parent-gnode gnode 2) 551 - (552 192) ())) (568 . #s((terminal-gnode (1 #t) gnode 2) 567 displayln #t)) (569 . #s((terminal-gnode (1 #t) gnode 2) 569 - #t)) (570 . #s((terminal-gnode (1 #t) gnode 2) 570 0 #t)) (572 . #s((parent-gnode gnode 2) 572 - (573 574 577) ())) (573 . #s((terminal-gnode (1 #t) gnode 2) 572 begin #t)) (574 . #s((parent-gnode gnode 2) 574 - (575) ())) (575 . #s((terminal-gnode (1 #t) gnode 2) 574 displayln #t)) (560 . #s((terminal-gnode (1 #t) gnode 2) 559 begin #t)) (561 . #s((parent-gnode gnode 2) 561 - (562) ())) (562 . #s((terminal-gnode (1 #t) gnode 2) 561 displayln #t)) (563 . #s((terminal-gnode (1 #t) gnode 2) 563 - #t)) (564 . #s((terminal-gnode (1 #t) gnode 2) 564 0 #t)) (565 . #s((parent-gnode gnode 2) 565 - (566 567 570) ())) (566 . #s((terminal-gnode (1 #t) gnode 2) 565 begin #t)) (567 . #s((parent-gnode gnode 2) 567 - (568) ())) (585 . #s((terminal-gnode (1 #t) gnode 2) 585 255 #t)) (584 . #s((terminal-gnode (1 #t) gnode 2) 584 255 #t)) (587 . #s((terminal-gnode (1 #t) gnode 2) 586 - #t)) (586 . #s((parent-gnode gnode 2) 586 - (587 534) ())) (589 . #s((parent-gnode gnode 2) 589 - (590 192) ())) (588 . #s((terminal-gnode (1 #t) gnode 2) 588 - #t)) (591 . #s((terminal-gnode (1 #t) gnode 2) 591 - #t)) (590 . #s((terminal-gnode (1 #t) gnode 2) 589 disk-utterance-thstart #t)) (577 . #s((parent-gnode gnode 2) 577 - (578 582) ())) (576 . #s((terminal-gnode (1 #t) gnode 2) 576 - #t)) (579 . #s((terminal-gnode (1 #t) gnode 2) 579 255 #t)) (578 . #s((terminal-gnode (1 #t) gnode 2) 577 quote #t)) (581 . #s((terminal-gnode (1 #t) gnode 2) 581 255 #t)) (580 . #s((terminal-gnode (1 #t) gnode 2) 580 255 #t)) (583 . #s((terminal-gnode (1 #t) gnode 2) 582 255 #t)) (582 . #s((parent-gnode gnode 2) 582 - (583 584 585) ())) (601 . #s((terminal-gnode (1 #t) gnode 2) 599 / #t)) (600 . #s((variable-gnode gnode 2) 600 center-theta 599)) (603 . #s((terminal-gnode (1 #t) gnode 2) 602 + #t)) (602 . #s((parent-gnode gnode 2) 602 - (603 604) ())) (605 . #s((terminal-gnode (1 #t) gnode 2) 604 - #t)) (604 . #s((parent-gnode gnode 2) 604 - (605) ())) (607 . #s((parent-gnode gnode 2) 607 - (608 192) ())) (606 . #s((terminal-gnode (1 #t) gnode 2) 599 + #t)) (593 . #s((terminal-gnode (1 #t) gnode 2) 592 * #t)) (592 . #s((parent-gnode gnode 2) 592 - (593 598 594 600) ())) (595 . #s((terminal-gnode (1 #t) gnode 2) 594 / #t)) (594 . #s((parent-gnode gnode 2) 594 - (595 596 597) ())) (597 . #s((terminal-gnode (1 #t) gnode 2) 597 pi #t)) (596 . #s((terminal-gnode (1 #t) gnode 2) 596 180 #t)) (599 . #s((parent-gnode gnode 2) 599 - (606 607 610) ())) (598 . #s((terminal-gnode (1 #t) gnode 2) 598 |-1| #t)) (617 . #s((parent-gnode gnode 2) 617 - (620 192) ())) (616 . #s((parent-gnode gnode 2) 616 - (618 192) ())) (619 . #s((terminal-gnode (1 #t) gnode 2) 619 - #t)) (618 . #s((terminal-gnode (1 #t) gnode 2) 616 disk-utterance-thrange #t)) (621 . #s((terminal-gnode (1 #t) gnode 2) 621 - #t)) (620 . #s((terminal-gnode (1 #t) gnode 2) 617 disk-utterance-thstart #t)) (623 . #s((terminal-gnode (1 #t) gnode 2) 623 - #t)) (622 . #s((terminal-gnode (1 #t) gnode 2) 622 - #t)) (609 . #s((terminal-gnode (1 #t) gnode 2) 609 - #t)) (608 . #s((terminal-gnode (1 #t) gnode 2) 607 disk-utterance-thstart #t)) (611 . #s((terminal-gnode (1 #t) gnode 2) 610 / #t)) (610 . #s((parent-gnode gnode 2) 610 - (611 624 612) ())) (613 . #s((terminal-gnode (1 #t) gnode 2) 613 - #t)) (612 . #s((terminal-gnode (1 #t) gnode 2) 612 2 #t)) (615 . #s((terminal-gnode (1 #t) gnode 2) 614 - #t)) (614 . #s((parent-gnode gnode 2) 614 - (615 616 617) ())) (633 . #s((variable-gnode gnode 2) 633 rr 637)) (632 . #s((terminal-gnode (1 #t) gnode 2) 632 - #t)) (635 . #s((variable-gnode gnode 2) 635 rr 636)) (634 . #s((terminal-gnode (1 #t) gnode 2) 634 - #t)) (637 . #s((argument-gnode (1 #t) gnode 2) 637 arger #t)) (636 . #s((argument-gnode (1 #t) gnode 2) 636 arger #t)) (639 . #s((terminal-gnode (1 #t) gnode 2) 638 - #t)) (638 . #s((parent-gnode gnode 2) 638 - (629 279) ())) (625 . #s((terminal-gnode (1 #t) gnode 2) 624 disk-utterance-thrange #t)) (624 . #s((parent-gnode gnode 2) 624 - (625 192) ())) (626 . #s((terminal-gnode (1 #t) gnode 2) 626 - #t)) (629 . #s((function-gnode variable-gnode 1 gnode 2) 629 xs 271 (636))) (631 . #s((terminal-gnode (1 #t) gnode 2) 631 rr #t)) (630 . #s((function-gnode variable-gnode 1 gnode 2) 630 ys 304 (637))) (650 . #s((terminal-gnode (1 #t) gnode 2) 649 - #t)) (651 . #s((terminal-gnode (1 #t) gnode 2) 651 - #t)) (648 . #s((terminal-gnode (1 #t) gnode 2) 647 - #t)) (649 . #s((parent-gnode gnode 2) 649 - (650 279 652) ())) (654 . #s((parent-gnode gnode 2) 654 - (630 656) ())) (655 . #s((terminal-gnode (1 #t) gnode 2) 654 - #t)) (652 . #s((terminal-gnode (1 #t) gnode 2) 652 1 #t)) (642 . #s((terminal-gnode (1 #t) gnode 2) 641 - #t)) (643 . #s((terminal-gnode (1 #t) gnode 2) 643 - #t)) (640 . #s((terminal-gnode (1 #t) gnode 2) 640 - #t)) (641 . #s((parent-gnode gnode 2) 641 - (630 279) ())) (646 . #s((terminal-gnode (1 #t) gnode 2) 646 - #t)) (647 . #s((parent-gnode gnode 2) 647 - (629 649) ())) (644 . #s((parent-gnode gnode 2) 644 - (645 258 660 663) ())) (645 . #s((terminal-gnode (1 #t) gnode 2) 644 for-each #t)) (666 . #s((terminal-gnode (1 #t) gnode 2) 665 - #t)) (667 . #s((terminal-gnode (1 #t) gnode 2) 667 1 #t)) (664 . #s((terminal-gnode (1 #t) gnode 2) 663 reverse #t)) (665 . #s((parent-gnode gnode 2) 665 - (666 531 667) ())) (670 . #s((terminal-gnode (1 #t) gnode 2) 670 1 #t)) (671 . #s((parent-gnode gnode 2) 671 - (672 673 678 690) ())) (668 . #s((parent-gnode gnode 2) 668 - (669 536 670) ())) (669 . #s((terminal-gnode (1 #t) gnode 2) 668 - #t)) (658 . #s((terminal-gnode (1 #t) gnode 2) 658 - #t)) (659 . #s((terminal-gnode (1 #t) gnode 2) 659 1 #t)) (656 . #s((parent-gnode gnode 2) 656 - (657 279 659) ())) (657 . #s((terminal-gnode (1 #t) gnode 2) 656 - #t)) (662 . #s((terminal-gnode (1 #t) gnode 2) 662 - #t)) (663 . #s((parent-gnode gnode 2) 663 - (664 654) ())) (660 . #s((parent-gnode gnode 2) 660 - (661 647) ())) (661 . #s((terminal-gnode (1 #t) gnode 2) 660 reverse #t)) (682 . #s((terminal-gnode (1 #t) gnode 2) 682 - #t)) (683 . #s((terminal-gnode (1 #t) gnode 2) 683 0 #t)) (680 . #s((parent-gnode gnode 2) 680 - (681 158) ())) (681 . #s((terminal-gnode (1 #t) gnode 2) 680 whole-tree-offset-y #t)) (686 . #s((parent-gnode gnode 2) 686 - (687 688) ())) (687 . #s((terminal-gnode (1 #t) gnode 2) 686 displayln #t)) (684 . #s((parent-gnode gnode 2) 684 - (685 686 689) ())) (685 . #s((terminal-gnode (1 #t) gnode 2) 684 begin #t)) (674 . #s((terminal-gnode (1 #t) gnode 2) 674 whole-tree-offset-x #t)) (675 . #s((terminal-gnode (1 #t) gnode 2) 674 - #t)) (672 . #s((terminal-gnode (1 #t) gnode 2) 671 gl-translate #t)) (673 . #s((parent-gnode gnode 2) 673 - (674 158) ())) (678 . #s((parent-gnode gnode 2) 678 - (679 680) ())) (679 . #s((terminal-gnode (1 #t) gnode 2) 678 - #t)) (676 . #s((terminal-gnode (1 #t) gnode 2) 676 - #t)) (677 . #s((terminal-gnode (1 #t) gnode 2) 677 - #t)) (690 . #s((terminal-gnode (1 #t) gnode 2) 690 0 #t)) (691 . #s((terminal-gnode (1 #t) gnode 2) 691 0 #t)) (688 . #s((terminal-gnode (1 #t) gnode 2) 688 |"yo"| #t)) (689 . #s((terminal-gnode (1 #t) gnode 2) 689 100 #t)) (694 . #s((terminal-gnode (1 #t) gnode 2) 694 2 #t)) (695 . #s((terminal-gnode (1 #t) gnode 2) 695 pi #t)) (692 . #s((parent-gnode gnode 2) 692 - (693 694 695) ())) (693 . #s((terminal-gnode (1 #t) gnode 2) 692 * #t)))


--------------------------------------------------------------------------------
/visualizations/helpers/def-painter.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require sgl sgl/gl)
  4 | (require "../../core/common.rkt")
  5 | 
  6 | ;(struct cartesian-utterance utterance (x y w h text-w text-h))
  7 | 
  8 | (provide def-painter)
  9 | 
 10 | (define (inv? x y w h tree)
 11 |  (or
 12 |   (and (< (+ x w) (- (whole-tree-offset-x tree))) (not VERTICAL))
 13 |   (and (< (+ y h) (- (whole-tree-offset-y tree))) VERTICAL)
 14 |   (> x (- (/ (whole-tree-w tree) (whole-tree-zoom tree)) (whole-tree-offset-x tree)))
 15 |   (> y (- (/ (whole-tree-h tree) (whole-tree-zoom tree)) (whole-tree-offset-y tree)))))
 16 | 
 17 | ;(define (center offset lenwhole lenpiece start width)
 18 | ; (let ((visible-width (- (min (+ offset lenwhole) (+ start width)) (max offset start))))
 19 | ;  (if (< visible-width lenpiece)
 20 | ;   (if (< offset start)
 21 | ;    (- (+ offset lenwhole) lenpiece)
 22 | ;    offset)
 23 | ;   (+ (max offset start) (/ visible-width 2) (- (/ lenpiece 2))))))
 24 | 
 25 | (define image-dir "/home/philip/olddesktop/vilisp/vilisp/semantic/images/")
 26 | 
 27 | (define (def-painter #:drawer (drawer values) #:invisible? (invisible? inv?))
 28 |  (define image '())
 29 |  (define images '())
 30 |  (define repetitions 1)
 31 | ; (define image-files '("galaxies.png"))
 32 |  (define image-files '("360milky_way_over_tenerife.jpg"))
 33 | ; (define image-files (map (lambda (n) (string-append "time/" (number->string n) ".png")) (build-list 100 (curry + 1))))
 34 |  (define images-n (length image-files))
 35 |  (define images-dimensions (make-list images-n (map string->number (string-split (with-output-to-string (lambda () (system* "/usr/bin/identify" "-format" "%w %h" (string-append image-dir (car image-files)))))))))
 36 | ; (define images-dimensions (map
 37 | ;                            (lambda (img-n)
 38 | ;                             (map string->number (string-split (with-output-to-string (lambda () (system* "/usr/bin/identify" "-format" "%w %h" (string-append image-dir "time/" (number->string img-n) ".png")))))))
 39 | ;                            (build-list n (curry + 1))))
 40 |  (lambda (tree)
 41 |   (with
 42 |    (
 43 |     (if (null? images)
 44 |      (begin
 45 |       (glPixelStorei GL_UNPACK_ALIGNMENT 1)
 46 |       (map (lambda (img-f)
 47 |             (set! images (cons (SOIL_load_OGL_texture (string-append image-dir img-f) 0 0 4) images)))
 48 |            image-files)
 49 |       (set! images (reverse images)))
 50 |      '())
 51 |     (apply gl-scissor (whole-tree-dim tree))
 52 |     (apply gl-viewport (whole-tree-dim tree))
 53 | 
 54 |     (define distance 10)
 55 | 
 56 |     (gl-matrix-mode 'projection)
 57 |     (gl-load-identity)
 58 |     (gl-frustum
 59 |      0
 60 |      (whole-tree-w tree)
 61 |      (- (whole-tree-h tree))
 62 |      0
 63 |      1
 64 |      (* (/ (whole-tree-zoom tree)) distance))
 65 |     (gl-translate (whole-tree-offset-x tree) (- (whole-tree-offset-y tree)) (- 1 (/ (whole-tree-zoom tree))))
 66 |     (gl-matrix-mode 'modelview)
 67 |     (gl-load-identity)
 68 | 
 69 |     (glEnable GL_TEXTURE_2D)
 70 |     (gl-clear 'color-buffer-bit)
 71 |     (gl-color 1 0 0)
 72 | 
 73 |     (foldl
 74 |      (lambda (img img-d d)
 75 |       (let* ((x (car d))
 76 |              (next-x (+ x (car img-d)))
 77 |              (y (cdr d))
 78 |              (next-y (- (+ y (cadr img-d)))))
 79 |        (glBindTexture GL_TEXTURE_2D img)
 80 |        (gl-begin 'quads)
 81 |        (gl-tex-coord 0 0)
 82 |        (gl-vertex (* x distance) (* distance (- y)) (- distance))
 83 |        (gl-tex-coord repetitions 0)
 84 |        (gl-vertex (* distance next-x) (* distance (- y)) (- distance))
 85 |        (gl-tex-coord repetitions 1)
 86 |        (gl-vertex (* distance next-x) (* distance next-y) (- distance))
 87 |        (gl-tex-coord 0 1)
 88 |        (gl-vertex (* distance x) (* distance next-y) (- distance))
 89 |        (gl-end)
 90 |        (if (> x 50000) (cons 0 next-y) (cons next-x y))))
 91 |      '(0 . 0)
 92 |      images
 93 |      images-dimensions)
 94 | 
 95 |     (glDisable GL_TEXTURE_2D)
 96 | 
 97 |     (utterance-paint (whole-tree-utterance-tree tree) tree)
 98 |     )
 99 | 
100 |    (utterance-paint (u tree)
101 |     (let* ((x (cartesian-utterance-x u))
102 |            (y (cartesian-utterance-y u))
103 |            (w (cartesian-utterance-w u))
104 |            (h (cartesian-utterance-h u))
105 |            (args (utterance-args u)))
106 |      (if (invisible? x y w h tree)
107 |       '()
108 |       (begin
109 |        (drawer u tree)
110 | ;       (draw-rectangle (if (eq? Selected-tree tree) (cdr clr) (map (curryr / 3) (cdr clr))) x y w h)
111 | ;       (if (< (whole-tree-zoom tree) 1) '()
112 | ;        (draw-text
113 | ;         text
114 | ;         (* (whole-tree-zoom tree) (center x w (- text-w PADDING) (- (whole-tree-offset-x tree)) (whole-tree-w tree)))
115 | ;         (* (whole-tree-zoom tree) (+ text-h -3 (center y h text-h (- (whole-tree-offset-y tree)) (whole-tree-h tree))))
116 | ;         (car clr)
117 | ;         tree))
118 |        (map (curryr utterance-paint tree) args))))))))
119 | 
120 | 
121 | 


--------------------------------------------------------------------------------
/visualizations/helpers/default-v11n.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require sgl sgl/gl)
 4 | (require "../../core/common.rkt")
 5 | (require "def-painter.rkt")
 6 | (require "stdlib.rkt")
 7 | 
 8 | (provide make-default-v11n cartesian-utterance-x cartesian-utterance-y cartesian-utterance-w cartesian-utterance-h cartesian-utterance-text-w cartesian-utterance-text-h)
 9 | 
10 | (define (make-default-v11n #:child-w-generator (child-w-generator values) #:child-x-generator (child-x-generator values) #:child-y-generator (child-y-generator values) #:update-x-generator (update-x-generator values) #:update-y-generator (update-y-generator values) #:width-generator (width-generator values) #:height-generator (height-generator values))
11 |  (v11n
12 |   (def-painter
13 |    #:drawer generic-drawer)
14 | 
15 |   cartesian-utterance-generator
16 | 
17 |   (lambda (root x y tree)
18 |    (let find-utterance ((root root) (x x) (y y) (tree tree))
19 |     (with
20 |      ((if (or
21 |            (above-bottom-of-utterance?)
22 |            (utterance-is-closed?)
23 |            (has-no-children?)
24 |            (is-to-the-right-of-utterance?))
25 |        root
26 |        (pass-on-to-child)))
27 | 
28 |      (above-bottom-of-utterance? ()
29 |       (< (min-dim x y) (+ (cartesian-utterance-min-dim root) (cartesian-utterance-min-dim-span root))))
30 | 
31 |      (utterance-is-closed? ()
32 |       (closed? (utterance-node root) tree))
33 | 
34 |      (has-no-children? ()
35 |       (null? (node-args (utterance-node root))))
36 | 
37 |      (is-to-the-right-of-utterance? ()
38 |       (>= (maj-dim x y) (let ((baby (last (utterance-args root)))) (+ (cartesian-utterance-maj-dim baby) (cartesian-utterance-maj-dim-span baby)))))
39 | 
40 |      (pass-on-to-child ()
41 |       (ormap
42 |        (lambda (child)
43 |         (if (< (maj-dim x y) (+ (cartesian-utterance-maj-dim child) (cartesian-utterance-maj-dim-span child)))
44 |          (find-utterance child x y tree)
45 |          #f))
46 |        (utterance-args root))))))
47 | 
48 |   horiz-scroller))
49 | ;  (lambda (dir event)
50 | ;   (cond
51 | ;    ((eq? dir 'up)
52 | ;     (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))
53 | ;    ((eq? dir 'down)
54 | ;     (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
55 | ;    ((eq? dir 'left)
56 | ;     (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
57 | ;    ((eq? dir 'right)
58 | ;     (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))))))
59 | 
60 | (define (cartesian-utterance-maj-dim u) (if VERTICAL (cartesian-utterance-y u) (cartesian-utterance-x u)))
61 | (define (cartesian-utterance-maj-dim-span u) (if VERTICAL (cartesian-utterance-h u) (cartesian-utterance-w u)))
62 | (define (cartesian-utterance-min-dim u) (if VERTICAL (cartesian-utterance-x u) (cartesian-utterance-y u)))
63 | (define (cartesian-utterance-min-dim-span u) (if VERTICAL (cartesian-utterance-w u) (cartesian-utterance-h u)))
64 | 
65 | 


--------------------------------------------------------------------------------
/visualizations/helpers/linear-vertical-v11n.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require sgl sgl/gl)
 4 | (require "../../core/common.rkt")
 5 | (require "def-painter.ss")
 6 | (require "stdlib.rkt")
 7 | 
 8 | (provide make-linear-vertical-v11n other-v11n-utterance-total-height)
 9 | 
10 | (define (make-linear-vertical-v11n #:rectangle-drawer (drawer draw-rectangle-u) #:text-generator (text-generator straight-text))
11 |  (v11n
12 |   (def-painter
13 |    #:drawer 
14 |     (lambda (u tree)
15 |      (generic-drawer u tree #:drawer drawer #:text text-generator)))
16 | 
17 |   linear-vertical-utterance-generator
18 | 
19 |   (lambda (root x y tree)
20 |    (let find-utterance ((root root) (x x) (y y))
21 |     (with
22 |      ((if (or
23 |            (< y (+ (cartesian-utterance-y root) (cartesian-utterance-h root)))
24 |            (> y (+ (cartesian-utterance-y root) (other-v11n-utterance-total-height root))))
25 |        root
26 |        (ormap
27 |         (lambda (child)
28 |          (if (< y (+ (cartesian-utterance-y child) (other-v11n-utterance-total-height child)))
29 |           (find-utterance child x y)
30 |           #f))
31 |         (utterance-args root)))))))
32 | 
33 |   vert-scroller))
34 | ;  (lambda (dir event)
35 | ;   (cond
36 | ;    ((eq? dir 'up)
37 | ;     (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
38 | ;    ((eq? dir 'down)
39 | ;     (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))
40 | ;    ((eq? dir 'left)
41 | ;     (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
42 | ;    ((eq? dir 'right)
43 | ;     (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))))))
44 | 


--------------------------------------------------------------------------------
/visualizations/helpers/stdlib.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "../../core/common.rkt")
  4 | (require "def-painter.rkt")
  5 | 
  6 | (provide (all-defined-out))
  7 | 
  8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9 | ; drawing
 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 11 | 
 12 | (define-syntax-rule (when-space-for-text u tree text-drawer)
 13 |  (when (and
 14 |       (<= (/ (- (cartesian-utterance-text-w u) PADDING) (whole-tree-zoom tree)) (cartesian-utterance-w u))
 15 |       (<= (/ (cartesian-utterance-text-h u) (whole-tree-zoom tree)) (cartesian-utterance-h u)))
 16 |   text-drawer))
 17 | 
 18 | (define (draw-rectangle-u u tree)
 19 |  (draw-rectangle (cdr (utterance-clr u)) (cartesian-utterance-x u) (cartesian-utterance-y u) (cartesian-utterance-w u) (cartesian-utterance-h u)))
 20 | 
 21 | (define (straight-text u tree)
 22 |  ((node-text-func (utterance-node u)) (utterance-node u)))
 23 | 
 24 | (define (rectangle-drawer u tree)
 25 |  (generic-drawer u tree #:drawer draw-rectangle-u #:text straight-text))
 26 | 
 27 | (define (generic-drawer u tree #:drawer (drawer draw-rectangle-u) #:text (text straight-text))
 28 |  (drawer u tree)
 29 |  (when-space-for-text u tree
 30 |   (draw-text (text u tree) (center-x u tree) (center-y u tree) (car (utterance-clr u)))))
 31 | 
 32 | (define (center-x u tree)
 33 |  (center (cartesian-utterance-x u) (cartesian-utterance-w u) (- (cartesian-utterance-text-w u) PADDING) (- (whole-tree-offset-x tree)) (whole-tree-w tree)))
 34 | 
 35 | (define (center-y u tree)
 36 |  (+ (cartesian-utterance-text-h u) -3 (center (cartesian-utterance-y u) (cartesian-utterance-h u) (- (cartesian-utterance-text-h u) PADDING) (- (whole-tree-offset-y tree)) (whole-tree-h tree))))
 37 | 
 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 39 | ; utterance-generation
 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 41 | 
 42 | (define (cartesian-utterance-generator n tree)
 43 |  (generic-utterance-generator n tree cartesian-utterance
 44 |   (list 0
 45 |    (lambda (data chs arg n) data)
 46 |    (lambda (data chs res n) (+ data (cartesian-utterance-w res)))
 47 |    (lambda (data chi n) data))
 48 |   (list 0
 49 |    (lambda (data chs arg n) (+ data CELLHEIGHT))
 50 |    (lambda (data chs res n) data)
 51 |    (lambda (data chi n) data))
 52 |   (list 0
 53 |    (lambda (data chs arg n) data)
 54 |    (lambda (data chs res n) data)
 55 |    (lambda (data chi n) (max (box-width ((node-text-func n) n)) (apply + (map cartesian-utterance-w chi)))))
 56 |   (list CELLHEIGHT
 57 |    (lambda (data chs arg n) data)
 58 |    (lambda (data chs res n) data)
 59 |    (lambda (data chi n) data))
 60 |   (list 0
 61 |    (lambda (data chs arg n) data)
 62 |    (lambda (data chs res n) data)
 63 |    (lambda (data chi n) (box-width ((node-text-func n) n))))
 64 |   (list 0
 65 |    (lambda (data chs arg n) data)
 66 |    (lambda (data chs res n) data)
 67 |    (lambda (data chi n) (box-height ((node-text-func n) n))))))
 68 | 
 69 | (struct other-v11n-utterance cartesian-utterance (total-height))
 70 | 
 71 | (define (linear-vertical-utterance-generator n tree)
 72 |  (generic-utterance-generator n tree other-v11n-utterance
 73 |   (list 0
 74 |    (lambda (data chs arg n) (+ data 10))
 75 |    (lambda (data chs res n) data)
 76 |    (lambda (data chi n) data))
 77 |   (list 0
 78 |    (lambda (data chs arg n) (+ CELLHEIGHT data))
 79 |    (lambda (data chs res n) (+ data (other-v11n-utterance-total-height res)))
 80 |    (lambda (data chi n) data))
 81 |   (list 0
 82 |    (lambda (data chs arg n) data)
 83 |    (lambda (data chs res n) data)
 84 |    (lambda (data chi n) (box-width ((node-text-func n) n))))
 85 |   (list CELLHEIGHT
 86 |    (lambda (data chs arg n) data)
 87 |    (lambda (data chs res n) data)
 88 |    (lambda (data chi n) data))
 89 |   (list 0
 90 |    (lambda (data chs arg n) data)
 91 |    (lambda (data chs res n) data)
 92 |    (lambda (data chi n) (box-width ((node-text-func n) n))))
 93 |   (list 0
 94 |    (lambda (data chs arg n) data)
 95 |    (lambda (data chs res n) data)
 96 |    (lambda (data chi n) (box-height ((node-text-func n) n))))
 97 |   (list 0
 98 |    (lambda (data chs arg n) data)
 99 |    (lambda (data chs res n) data)
100 |    (lambda (data chi n) (apply + CELLHEIGHT (map other-v11n-utterance-total-height chi))))))
101 | 
102 | (define (generic-utterance-generator n tree utterance-constructor . chrs)
103 |  (let ((inits (map car chrs))
104 |        (make-children (map cadr chrs))
105 |        (updates (map caddr chrs))
106 |        (finals (map cadddr chrs)))
107 |   (let node->utterance ((n n) (tree tree) (characteristics inits))
108 |    (let ((children
109 |           (if (closed? n tree)
110 |            '()
111 |            (car
112 |             (foldl
113 |              (lambda (arg data)
114 |               (let ((res (node->utterance
115 |                           arg
116 |                           tree
117 |                           (map (curryr apply (list characteristics arg n)) make-children (cdr data)))))
118 |                (cons (append (car data) (list res)) (map (curryr apply (list characteristics res n)) updates (cdr data)))))
119 | 	     (cons '() characteristics)
120 | 	     (node-args n))))))
121 |     (apply
122 |      utterance-constructor
123 |      n
124 |      children
125 |      (get-color n tree)
126 |      (map (curryr apply children (list n)) finals characteristics))))))
127 | 
128 | (define (horiz-scroller dir event)
129 |  (cond
130 |   ((eq? dir 'up)
131 |    (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))
132 |   ((eq? dir 'down)
133 |    (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
134 |   ((eq? dir 'left)
135 |    (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
136 |   ((eq? dir 'right)
137 |    (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))))
138 | 
139 | (define (vert-scroller dir event)
140 |  (cond
141 |   ((eq? dir 'up)
142 |    (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree))))
143 |   ((eq? dir 'down)
144 |    (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))
145 |   ((eq? dir 'left)
146 |    (set-whole-tree-offset-x! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-x Selected-tree))))
147 |   ((eq? dir 'right)
148 |    (set-whole-tree-offset-x! Selected-tree (+ SCROLLDIST (whole-tree-offset-x Selected-tree))))))
149 | 


--------------------------------------------------------------------------------
/visualizations/other-v11n.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require sgl sgl/gl)
 4 | (require "../core/common.rkt")
 5 | (require "helpers/linear-vertical-v11n.rkt")
 6 | 
 7 | (provide visualization)
 8 | 
 9 | (define visualization
10 |  (make-linear-vertical-v11n
11 |   #:rectangle-drawer
12 |    (lambda (u tree)
13 |     (draw-rectangle (if (eq? Selected-tree tree) (cdr (utterance-clr u)) (map (curryr / 3) (cdr (utterance-clr u)))) (cartesian-utterance-x u) (cartesian-utterance-y u) (cartesian-utterance-w u) (cartesian-utterance-h u)))))
14 | 
15 | 


--------------------------------------------------------------------------------
/visualizations/other2-v11n.phl_inactive:
--------------------------------------------------------------------------------
1 | #hash((0 . #s((parent-gnode gnode 2) 0 - (1 9 12) ())) (1 . #s((parent-gnode gnode 2) 1 - (2 3 4 5 6) ())) (2 . #s((terminal-gnode (1 #t) gnode 2) 1 require #t)) (3 . #s((terminal-gnode (1 #t) gnode 2) 3 sgl #t)) (4 . #s((terminal-gnode (1 #t) gnode 2) 4 sgl/gl #t)) (5 . #s((terminal-gnode (1 #t) gnode 2) 5 |"../core/common.rkt"| #t)) (6 . #s((terminal-gnode (1 #t) gnode 2) 6 |"helpers/linear-vertical-v11n.rkt"| #t)) (9 . #s((parent-gnode gnode 2) 9 - (10 11) ())) (10 . #s((terminal-gnode (1 #t) gnode 2) 9 provide #t)) (11 . #s((terminal-gnode (1 #t) gnode 2) 11 visualization #t)) (next-id . 65) (12 . #s((parent-gnode gnode 2) 12 - (13 14 15) ())) (13 . #s((terminal-gnode (1 #t) gnode 2) 12 define #t)) (14 . #s((terminal-gnode (1 #t) gnode 2) 14 visualization #t)) (15 . #s((parent-gnode gnode 2) 15 - (16 58 60) (60 19))) (16 . #s((terminal-gnode (1 #t) gnode 2) 15 make-linear-vertical-v11n #t)) (17 . #s((terminal-gnode (1 #t) gnode 2) 17 |#:rectangle-drawer| #t)) (18 . #s((parent-gnode gnode 2) 18 - (20 21 48 49 50 51) (51 50 49 48))) (19 . #s((function-gnode variable-gnode 1 gnode 2) 19 drawer 18 (52 53 54 55 56 57))) (20 . #s((terminal-gnode (1 #t) gnode 2) 18 draw-rectangle #t)) (21 . #s((parent-gnode gnode 2) 21 - (22 23 28 32) (42))) (22 . #s((terminal-gnode (1 #t) gnode 2) 21 if #t)) (23 . #s((parent-gnode gnode 2) 23 - (24 25 27) (27))) (24 . #s((terminal-gnode (1 #t) gnode 2) 23 eq? #t)) (25 . #s((terminal-gnode (1 #t) gnode 2) 25 Selected-tree #t)) (26 . #s((terminal-gnode (1 #t) gnode 2) 26 - #t)) (27 . #s((variable-gnode gnode 2) 27 tree 57)) (28 . #s((parent-gnode gnode 2) 28 - (29 42) (31))) (29 . #s((terminal-gnode (1 #t) gnode 2) 28 cdr #t)) (30 . #s((terminal-gnode (1 #t) gnode 2) 30 - #t)) (31 . #s((variable-gnode gnode 2) 31 clr 30)) (32 . #s((parent-gnode gnode 2) 32 - (33 34 38) ())) (33 . #s((terminal-gnode (1 #t) gnode 2) 32 map #t)) (34 . #s((parent-gnode gnode 2) 34 - (35 36 37) ())) (35 . #s((terminal-gnode (1 #t) gnode 2) 34 curryr #t)) (36 . #s((terminal-gnode (1 #t) gnode 2) 36 / #t)) (37 . #s((terminal-gnode (1 #t) gnode 2) 37 3 #t)) (38 . #s((parent-gnode gnode 2) 38 - (39 42) ())) (39 . #s((terminal-gnode (1 #t) gnode 2) 38 cdr #t)) (40 . #s((terminal-gnode (1 #t) gnode 2) 40 - #t)) (41 . #s((terminal-gnode (1 #t) gnode 2) 41 - #t)) (42 . #s((variable-gnode gnode 2) 42 clr 52)) (43 . #s((terminal-gnode (1 #t) gnode 2) 43 - #t)) (44 . #s((terminal-gnode (1 #t) gnode 2) 44 - #t)) (45 . #s((terminal-gnode (1 #t) gnode 2) 45 - #t)) (46 . #s((terminal-gnode (1 #t) gnode 2) 46 - #t)) (47 . #s((terminal-gnode (1 #t) gnode 2) 47 - #t)) (48 . #s((variable-gnode gnode 2) 48 x 53)) (49 . #s((variable-gnode gnode 2) 49 y 54)) (50 . #s((variable-gnode gnode 2) 50 w 55)) (51 . #s((variable-gnode gnode 2) 51 h 56)) (52 . #s((argument-gnode (1 #t) gnode 2) 52 arger #t)) (53 . #s((argument-gnode (1 #t) gnode 2) 53 arger #t)) (54 . #s((argument-gnode (1 #t) gnode 2) 54 arger #t)) (55 . #s((argument-gnode (1 #t) gnode 2) 55 arger #t)) (56 . #s((argument-gnode (1 #t) gnode 2) 56 arger #t)) (57 . #s((argument-gnode (1 #t) gnode 2) 57 arger #t)) (58 . #s((terminal-gnode (1 #t) gnode 2) 58 |#:text-generator| #t)) (59 . #s((parent-gnode gnode 2) 59 - (61 62 64) ())) (60 . #s((function-gnode variable-gnode 1 gnode 2) 60 text-gen 59 (64))) (61 . #s((terminal-gnode (1 #t) gnode 2) 59 format #t)) (62 . #s((terminal-gnode (1 #t) gnode 2) 62 |"//~a"| #t)) (63 . #s((terminal-gnode (1 #t) gnode 2) 63 text #t)) (64 . #s((argument-gnode (1 #t) gnode 2) 64 arger #t)))


--------------------------------------------------------------------------------
/visualizations/other2-v11n.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | 
3 | (require sgl sgl/gl "../core/common.rkt" "helpers/linear-vertical-v11n.rkt")
4 | (provide visualization)
5 | (define visualization (letrec ((v60 (lambda (v64) (format "//~a" v64))) (v19 (lambda (v52 v53 v54 v55 v56 v57) (letrec ((v51 v56) (v50 v55) (v49 v54) (v48 v53)) (draw-rectangle (letrec ((v42 v52)) (if (letrec ((v27 v57)) (eq? Selected-tree v27)) (letrec ((v31 -)) (cdr v42)) (map (curryr / 3) (cdr v42)))) v48 v49 v50 v51))))) (make-linear-vertical-v11n #:text-generator v60)))
6 | 


--------------------------------------------------------------------------------
/visualizations/treemap-v11n.rkt_inactive:
--------------------------------------------------------------------------------
1 | #lang racket
2 | 
3 | (require sgl sgl/gl "../core/common.rkt" "helpers/def-painter.rkt")
4 | (provide visualization)
5 | ;(struct cartesian-utterance utterance (x y w h text-w text-h))
6 | (struct treemap-utterance cartesian-utterance (total-width total-height))
7 | (define visualization (letrec ((v147 (lambda (a391 a399) (letrec ((v149 (lambda (a182 a183 a184 a210 a247 a249 a336 a390) (letrec ((v179 a182) (v209 a210) (v180 a183) (v181 a184) (v201 a390) (v248 a249) (v262 ((node-text-func v179) v179)) (v246 a247) (v335 a336) (v265 (if (or (closed? v179 v201) (null? (node-args v179))) null (letrec ((v287 (lambda (a316 a339) (letrec ((v343 (+ 1 (length (node-args v179)))) (v324 (/ (if (eq? v248 (quote horizontal)) v209 v246) v343)) (v315 a316) (v338 a339)) (if (eq? v248 (quote horizontal)) (letrec ((v696 (* 9/10 v246))) (v149 v315 (+ v180 (* v338 v324)) (center v181 v246 v696 0 +inf.0) v324 v696 (quote vertical) (+ 1 v335) v201)) (letrec ((v688 (* 9/10 v209))) (v149 v315 (center v180 v209 v688 0 +inf.0) (+ v181 (* v338 v324)) v688 v324 (quote horizontal) (+ 1 v335) v201))))))) (map v287 (node-args v179) (map (curry + 1) (build-list (length (node-args v179)) identity))))))) (treemap-utterance v179 v265 (get-color v179 v201) v180 v181 (or (and (or (eq? v248 (quote vertical)) (closed? v179 v201) (null? (node-args v179))) v209) (/ v209 (+ 1 (length (node-args v179))))) (or (and (or (eq? v248 (quote horizontal)) (closed? v179 v201) (null? (node-args v179))) v246) (/ v246 (+ 1 (length (node-args v179))))) (box-width v262) (box-height v262) v209 v246)))) (v151 a391) (v153 0) (v155 0) (v157 -) (v164 0) (v166 -) (v168 -) (v171 a399)) (v149 v151 v153 v155 (whole-tree-w v171) (whole-tree-h v171) (quote horizontal) v164 v171)))) (v436 (lambda (a455 a487 a488 a637) (letrec ((v439 (lambda (a451) (letrec ((v450 a451) (v467 a488) (v484 a487)) (if (or (and (= (cartesian-utterance-w v450) (treemap-utterance-total-width v450)) (< v467 (+ (cartesian-utterance-y v450) (cartesian-utterance-h v450)))) (and (= (cartesian-utterance-h v450) (treemap-utterance-total-height v450)) (< v484 (+ (cartesian-utterance-x v450) (cartesian-utterance-w v450)))) (null? (utterance-args v450))) v450 (letrec ((v506 (lambda (a522) (letrec ((v521 a522)) (if (and (>= v467 (cartesian-utterance-y v521)) (< v467 (+ (cartesian-utterance-y v521) (treemap-utterance-total-height v521))) (>= v484 (cartesian-utterance-x v521)) (< v484 (+ (cartesian-utterance-x v521) (treemap-utterance-total-width v521)))) (v439 v521) #f))))) (ormap v506 (utterance-args v450))))))) (v453 a455) (v636 a637)) (or (v439 v453) v453 v636)))) (v560 (lambda (a567 a643) (letrec ((v566 a567) (v642 a643)) (cond ((eq? v566 (quote up)) (set-whole-tree-zoom! Selected-tree (* (/ 1.2) (whole-tree-zoom Selected-tree)))) ((eq? v566 (quote down)) (set-whole-tree-zoom! Selected-tree (* 1.2 (whole-tree-zoom Selected-tree)))) ((eq? v566 (quote left)) (set-whole-tree-offset-y! Selected-tree (+ SCROLLDIST (whole-tree-offset-y Selected-tree)))) ((eq? v566 (quote right)) (set-whole-tree-offset-y! Selected-tree (+ (- SCROLLDIST) (whole-tree-offset-y Selected-tree))))))))) (v11n (letrec ((v9 (lambda (a134 a135 a136 a137 a138 a139 a140 a141 a143 a144 a145) (letrec ((v19 a144) (v29 a141) (v37 a135) (v38 a136) (v58 a137) (v69 a138)) (begin (letrec ((v39 (treemap-utterance-total-width a143)) (v40 (treemap-utterance-total-height a143))) (draw-rectangle (if (eq? Selected-tree v19) (cdr v29) (map (curry / 3) (cdr v29))) v37 v38 v39 v40)) (letrec ((v52 a139) (v64 a140)) (if (and (< (/ (- v52 PADDING) (whole-tree-zoom v19)) v58) (< (/ v64 (whole-tree-zoom v19)) v69)) (letrec ((v73 a134) (v76 a145)) (draw-text v73 (v76 v37 v58 (- v52 PADDING) (- (whole-tree-offset-x v19)) (whole-tree-w v19)) (+ v64 -3 (v76 v38 v69 v64 (- (whole-tree-offset-y v19)) (whole-tree-h v19))) (car v29))) null)))))) (v123 (lambda (a129 a130 a131 a132 a133) #f))) (def-painter #:drawer v9 #:invisible? v123)) v147 v436 v560)))
8 | 


--------------------------------------------------------------------------------