843 lines
47 KiB
Scheme
843 lines
47 KiB
Scheme
; DrScheme starts counting positions at 0, MzScheme starts counting positions at 1.
|
|
; Syntax objects use MzScheme positions, all the positions in this file use DrScheme
|
|
; positions. In all cases positions are exact non-negative integer.
|
|
; Among DrScheme positions, some are so-called new positions "new-pos" and some are
|
|
; old positions "old-pos". An old position is a position in the editor before any snip
|
|
; was inserted. A new position is the same position in the editor, but after snips
|
|
; might have been inserted.
|
|
; (define-type position exact-non-negative-integer)
|
|
; DrScheme also has locations, which are real x and y coordinates in the editor.
|
|
; (define-type location real) these are not used here but are used in the view part.
|
|
;
|
|
; This whole module can only deal with snips that are on the left of the label (see
|
|
; new-pos->old-pos and old-pos->new-pos for example).
|
|
|
|
(module snips-and-arrows-model (lib "mrflow.ss" "mrflow")
|
|
(require
|
|
(prefix lst: (lib "list.ss"))
|
|
|
|
(prefix cst: "constants.ss")
|
|
;"set-list.ss"
|
|
"set-hash.ss"
|
|
;"assoc-set-list.ss"
|
|
"assoc-set-hash.ss"
|
|
"labels.ss"
|
|
)
|
|
|
|
; DATA STRUCTURES
|
|
; label label boolean
|
|
(define-struct arrow (start-label end-label tacked? color))
|
|
|
|
; exact-non-negative-integer
|
|
(define-struct snip-group (size))
|
|
|
|
; We could recompute left-new-pos on the fly (from the MzScheme
|
|
; pos from the label itself and old-pos->new-pos) each time we needed to repaint,
|
|
; but in practice we repaint much more often then we add snips, so we keep the pos
|
|
; here as a cache which is computed once from scratch when we add the label to
|
|
; displayed-arrows and which is then just updated each time we add a new snip.
|
|
; Likewise, total-number-of-snips could be recomputed on the fly from snip-groups-by-type,
|
|
; but is used as a cache to speed up old-pos->new-pos and new-pos->old-pos, which are used
|
|
; pretty often.
|
|
; Note that the data structure for a single arrow will be shared between two
|
|
; label-gui-data structures: it will appear once in the "starting-arrows"
|
|
; set for its start label, and once in the "ending-arrows" set for its end label.
|
|
; We need this because we need to be able to click at the end of an arrow and
|
|
; remove it if necessary.
|
|
(define-struct label-gui-data (; position
|
|
left-new-pos
|
|
; exact-integer
|
|
span-change
|
|
; exact-non-negative-integer
|
|
total-number-of-snips
|
|
; (assoc-setof symbol snip-group)
|
|
snip-groups-by-type
|
|
; (setof arrow)
|
|
starting-arrows
|
|
; (setof arrow)
|
|
ending-arrows))
|
|
|
|
; Note that several labels might have a given position (due to macros) and we use a list
|
|
; instead of a set because we expect the sets to be very small (i.e. only one label is
|
|
; normally registered for a given position, maybe two or three if there are macros, so
|
|
; we do expect the list to be very short) but we expect a great number of them (i.e. we
|
|
; expect pretty much all terms in a program to be registered). Sets have an better asymptotic
|
|
; access time but onyl for big sets compared to lists, and they consumme much more memory than
|
|
; lists (since we usually use the hash-table-based implementation of sets), so using lists
|
|
; here for labels-by-mzscheme-position is probably the fastest and most memory efficient
|
|
; solution here given our assumptions.
|
|
(define-struct source-gui-data (; (assoc-setof label label-gui-data)
|
|
label-gui-data-by-label
|
|
; (assoc-setof non-negative-exact-integer (non-empty-listof label))
|
|
labels-by-mzscheme-position
|
|
; exact-non-negative-integer
|
|
total-number-of-snips))
|
|
|
|
(define-struct gui-model-state (; (assoc-setof source source-gui-data)
|
|
source-gui-data-by-source
|
|
; (label -> top)
|
|
get-source-from-label
|
|
; (label -> non-negative-exact-integer)
|
|
get-mzscheme-position-from-label
|
|
; (label -> non-negative-exact-integer)
|
|
get-original-span-from-label
|
|
; (label -> non-negative-exact-integer)
|
|
get-span-from-label
|
|
; (listof symbol)
|
|
snip-type-list
|
|
))
|
|
|
|
(provide/contract
|
|
(make-gui-model-state ((label? . -> . any)
|
|
(label? . -> . non-negative-exact-integer?)
|
|
(label? . -> . non-negative-exact-integer?)
|
|
(listof symbol?)
|
|
. -> . gui-model-state?))
|
|
(rename get-related-labels-from-drscheme-new-pos-and-source
|
|
get-related-labels-from-drscheme-pos-and-source
|
|
(gui-model-state? non-negative-exact-integer? any/c . -> . (listof label?)))
|
|
(rename gui-model-state-get-span-from-label
|
|
make-get-span-from-label-from-model-state
|
|
(gui-model-state? . -> . (label? . -> . non-negative-exact-integer?)))
|
|
|
|
(for-each-source (gui-model-state? (any/c . -> . void?) . -> . void?))
|
|
(register-source-with-gui (gui-model-state? any/c . -> . any))
|
|
(is-source-registered? (gui-model-state? any/c . -> . boolean?))
|
|
|
|
(register-label-with-gui (gui-model-state? label? . -> . any))
|
|
(get-position-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
|
|
(user-change-terms (gui-model-state?
|
|
(listof label?)
|
|
any/c
|
|
non-negative-exact-integer?
|
|
. -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
|
|
(for-each-label-in-source (gui-model-state? any/c (label? . -> . void?) . -> . void?))
|
|
|
|
(add-arrow (gui-model-state? (list/c label? label? string?) boolean? . -> . void?))
|
|
(remove-arrows (gui-model-state? label? (or/c symbol? boolean?) boolean? . -> . void?))
|
|
(remove-all-arrows (gui-model-state? . -> . void?))
|
|
(for-each-arrow (gui-model-state? (non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? any/c any/c boolean? string? . -> . void?) . -> . void?))
|
|
(get-tacked-arrows-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
|
|
|
|
(for-each-snip-type (gui-model-state? (symbol? . -> . void?) . -> . void?))
|
|
(label-has-snips-of-this-type? (gui-model-state? label? symbol? . -> . boolean?))
|
|
(snips-currently-displayed-in-source? (gui-model-state? any/c . -> . boolean?))
|
|
(add-snips (gui-model-state? label? symbol? any/c non-negative-exact-integer? . -> . non-negative-exact-integer?))
|
|
(remove-inserted-snips (gui-model-state? label? symbol? any/c . -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
|
|
)
|
|
|
|
; (label -> top)
|
|
; (label -> non-negative-exact-integer)
|
|
; (label -> non-negative-exact-integer)
|
|
; (listof symbol)
|
|
; -> gui-model-state
|
|
(set! make-gui-model-state
|
|
(let ([real-make-gui-model-state make-gui-model-state])
|
|
(lambda (get-source-from-label
|
|
get-mzscheme-position-from-label
|
|
get-span-from-label
|
|
snip-type-list)
|
|
(let ([source-gui-data-by-source (assoc-set-make)])
|
|
(real-make-gui-model-state
|
|
source-gui-data-by-source
|
|
get-source-from-label
|
|
get-mzscheme-position-from-label
|
|
get-span-from-label
|
|
(lambda (label)
|
|
(let* ([span (get-span-from-label label)]
|
|
[source-gui-data
|
|
(assoc-set-get source-gui-data-by-source (get-source-from-label label))]
|
|
[label-gui-data
|
|
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
|
|
label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(+ span (label-gui-data-span-change label-gui-data))
|
|
span)))
|
|
snip-type-list)))))
|
|
|
|
|
|
; DRSCHEME / MZSCHEME CONVERSIONS
|
|
; non-negative-exact-integer -> non-negative-exact-integer
|
|
(define drscheme-pos->mzscheme-pos add1)
|
|
|
|
; non-negative-exact-integer -> non-negative-exact-integer
|
|
(define mzscheme-pos->drscheme-pos sub1)
|
|
|
|
|
|
; SOURCES
|
|
; gui-model-state top -> top
|
|
(define (register-source-with-gui gui-model-state source)
|
|
(assoc-set-set (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source
|
|
(make-source-gui-data (assoc-set-make)
|
|
(assoc-set-make)
|
|
0))
|
|
source)
|
|
|
|
; gui-model-state top -> boolean
|
|
(define (is-source-registered? gui-model-state source)
|
|
(assoc-set-in? (gui-model-state-source-gui-data-by-source gui-model-state) source))
|
|
|
|
; gui-model-state (top -> void) -> void
|
|
; applies f to each source
|
|
(define (for-each-source gui-model-state f)
|
|
(assoc-set-for-each (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
(lambda (source source-gui-data)
|
|
(f source)))
|
|
cst:void)
|
|
|
|
; gui-model-state top -> boolean
|
|
; are we currently displaying some snips in the source?
|
|
(define (snips-currently-displayed-in-source? gui-model-state source)
|
|
(let ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)])
|
|
(if source-gui-data
|
|
(< 0 (source-gui-data-total-number-of-snips source-gui-data))
|
|
#f)))
|
|
|
|
|
|
; LABELS
|
|
; gui-model-state label -> exact-non-negative-integer
|
|
; returns the left position of the expression. The computation is done from scratch,
|
|
; so only use this function if the position hasn't been yet cached in the label's gui data.
|
|
(define (get-new-pos-from-label gui-model-state label)
|
|
(old-pos->new-pos
|
|
gui-model-state
|
|
(mzscheme-pos->drscheme-pos
|
|
((gui-model-state-get-mzscheme-position-from-label gui-model-state) label))
|
|
((gui-model-state-get-source-from-label gui-model-state) label)))
|
|
|
|
; gui-model-state label -> exact-non-negative-integer
|
|
; returns the left position of the expression represented by the label
|
|
(define (get-position-from-label gui-model-state label)
|
|
(let* ([source ((gui-model-state-get-source-from-label gui-model-state) label)]
|
|
[source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)]
|
|
[label-gui-data-by-label
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)]
|
|
[label-gui-data
|
|
(assoc-set-get label-gui-data-by-label label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(label-gui-data-left-new-pos label-gui-data)
|
|
(get-new-pos-from-label gui-model-state label))))
|
|
|
|
; gui-model-state label -> (or/c top #f)
|
|
; we register the source of the label and the label by its position,
|
|
; but we don't associate any label-gui-data with it yet, to save memory.
|
|
; We'll associate some label-gui-data with it on the fly, as needed (when
|
|
; needing to remember some arrows or snips for that label, not before).
|
|
; We return the source only the first time a label is registered for it
|
|
; (the view part uses this to initialize the state of the source).
|
|
(define (register-label-with-gui gui-model-state label)
|
|
(let* ([source-gui-data-by-source
|
|
(gui-model-state-source-gui-data-by-source gui-model-state)]
|
|
[source
|
|
((gui-model-state-get-source-from-label gui-model-state) label)]
|
|
[source-gui-data
|
|
(assoc-set-get source-gui-data-by-source source cst:thunk-false)]
|
|
[mzscheme-pos
|
|
((gui-model-state-get-mzscheme-position-from-label gui-model-state) label)])
|
|
(if source-gui-data
|
|
(let ([labels-by-mzscheme-position
|
|
(source-gui-data-labels-by-mzscheme-position source-gui-data)])
|
|
; So, in the good old days I used to check whether a given label was already registered
|
|
; for the given position, and gave an error when such was the case. But macros can
|
|
; duplicate terms, so in the good not-so-old days I added a test such that an error
|
|
; would show up only if the labels didn't represent the same original term. But Matthew
|
|
; then told me that a given term that's duplicated by a macro might be represented by
|
|
; two syntax objects that are not eq?. So at that point I had the choice between
|
|
; converting the two syntax-objects into sexprs and using equal? to check whether
|
|
; they actually represented the same term (and that would have been only a heurisitc,
|
|
; since it would not have detected bugs in a macro that gave the same position to
|
|
; two identical source terms), or what I do now: just register all the labels no
|
|
; matter what. This solution also means I don't have to have a get-term-from-label
|
|
; function in my interface.
|
|
; Note that we still make sure the exact same label is not already registered with
|
|
; the gui, otherwise we'll try to add the same arrows twice which will lead to error
|
|
; messages in add-one-arrow-end
|
|
(let ([currently-registered-labels-for-this-position
|
|
(assoc-set-get labels-by-mzscheme-position
|
|
mzscheme-pos
|
|
cst:thunk-empty)])
|
|
(unless (memq label currently-registered-labels-for-this-position)
|
|
(assoc-set-set labels-by-mzscheme-position
|
|
mzscheme-pos
|
|
(cons label currently-registered-labels-for-this-position)
|
|
#f))
|
|
#f))
|
|
(begin
|
|
; source unknown: register it and try again
|
|
(register-source-with-gui gui-model-state source)
|
|
(register-label-with-gui gui-model-state label)
|
|
source))))
|
|
|
|
; gui-model-state (listof label) text% exact-integer -> (values non-negative-exact-integer non-negative-exact-integer)
|
|
; Modify the span of the labels and move snips on the right, returning the interval
|
|
; that has to be deleted and the new interval that has to be colored (for a total of
|
|
; three numbers, since both intervals start at the same position)
|
|
; We know from saav:user-change-terms that all the labels represent the same term
|
|
(define (user-change-terms gui-model-state labels source new-span)
|
|
(let* ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)]
|
|
[source-gui-data (assoc-set-get source-gui-data-by-source source)]
|
|
[label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
|
|
[label (car labels)]
|
|
[old-span ((gui-model-state-get-span-from-label gui-model-state) label)]
|
|
[change (- new-span old-span)]
|
|
[left-new-pos (get-position-from-label gui-model-state label)])
|
|
(for-each
|
|
(lambda (label)
|
|
(let ([label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(set-label-gui-data-span-change!
|
|
label-gui-data
|
|
(+ change (label-gui-data-span-change label-gui-data)))
|
|
(assoc-set-set label-gui-data-by-label
|
|
label
|
|
(make-label-gui-data left-new-pos
|
|
change
|
|
0
|
|
(assoc-set-make)
|
|
(set-make)
|
|
(set-make))))))
|
|
labels)
|
|
(move-poss gui-model-state source left-new-pos change + >)
|
|
(values (+ left-new-pos old-span) (+ left-new-pos new-span))))
|
|
|
|
; gui-model-state top (label -> void) -> void
|
|
; apply f to all registered labels
|
|
(define (for-each-label-in-source gui-model-state source f)
|
|
(let ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
|
|
(when source-gui-data
|
|
(assoc-set-for-each
|
|
(source-gui-data-labels-by-mzscheme-position source-gui-data)
|
|
(lambda (mzscheme-pos labels)
|
|
(for-each f labels)))))
|
|
cst:void)
|
|
|
|
|
|
; POS AND SOURCE TO LABEL CONVERSIONS
|
|
; gui-model-state non-negative-exact-integer top -> (listof label)
|
|
; finds the labels corresponding to a given new-pos in a given source
|
|
(define (get-related-labels-from-drscheme-new-pos-and-source gui-model-state new-pos source)
|
|
(get-related-labels-from-drscheme-old-pos-and-source
|
|
gui-model-state
|
|
(new-pos->old-pos gui-model-state new-pos source)
|
|
source))
|
|
|
|
; gui-model-state non-negative-exact-integer top -> (listof label)
|
|
; we loop down starting from old-pos, until we find a label. Then we have to check
|
|
; that the original old-pos falls within the original span of that label.
|
|
(define (get-related-labels-from-drscheme-old-pos-and-source gui-model-state old-pos source)
|
|
(let ([get-original-span-from-label
|
|
(gui-model-state-get-original-span-from-label gui-model-state)]
|
|
[source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)])
|
|
(if source-gui-data
|
|
(let ([labels-by-mzscheme-position (source-gui-data-labels-by-mzscheme-position source-gui-data)]
|
|
[starting-mzscheme-pos (drscheme-pos->mzscheme-pos old-pos)])
|
|
(let loop ([current-mzscheme-pos starting-mzscheme-pos])
|
|
(if (> 0 current-mzscheme-pos)
|
|
'()
|
|
(let ([labels (assoc-set-get labels-by-mzscheme-position current-mzscheme-pos cst:thunk-false)])
|
|
(if labels
|
|
; Note that if the label's span is too small, we stop looping.
|
|
; This means that in an expression like (abc def), if the mouse
|
|
; pointer points at the space character, #f will be returned,
|
|
; not the label for the whole expression.
|
|
(let ([mouse-distance (- starting-mzscheme-pos current-mzscheme-pos)])
|
|
(lst:filter (lambda (label)
|
|
(< mouse-distance (get-original-span-from-label label)))
|
|
labels))
|
|
(loop (sub1 current-mzscheme-pos)))))))
|
|
'())))
|
|
|
|
|
|
; OLD-POS / NEW-POS CONVERSIONS
|
|
; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
|
|
; converts an old position (before insertion of any snip) to a new position
|
|
; (after insertion of all the currently inserted snips).
|
|
; Note: the test is "<=", which means the new position is to the right of all
|
|
; the current snips that have positions corresponding to the same old position
|
|
; (i.e. to the right of all the snips that have already been inserted for that label).
|
|
(define (old-pos->new-pos gui-model-state old-pos source)
|
|
(let ([new-pos old-pos]
|
|
[get-mzscheme-position-from-label
|
|
(gui-model-state-get-mzscheme-position-from-label gui-model-state)]
|
|
[get-original-span-from-label
|
|
(gui-model-state-get-original-span-from-label gui-model-state)]
|
|
[get-span-from-label
|
|
(gui-model-state-get-span-from-label gui-model-state)]
|
|
[source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)])
|
|
(when source-gui-data
|
|
(assoc-set-for-each
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)
|
|
(lambda (label label-gui-data)
|
|
(let ([label-left-old-pos (mzscheme-pos->drscheme-pos (get-mzscheme-position-from-label label))])
|
|
(cond
|
|
; the order of the clauses is important here
|
|
; old-pos is on the right of the original expression represented by the label
|
|
[(<= (+ label-left-old-pos (get-original-span-from-label label)) old-pos)
|
|
(set! new-pos (+ new-pos
|
|
(label-gui-data-span-change label-gui-data)
|
|
(label-gui-data-total-number-of-snips label-gui-data)))]
|
|
; old-pos is somewhere in the middle of the expression represented by the label
|
|
; then we have to take care of the case when the current expression is smaller than
|
|
; the original expression (because an identifier was changed)
|
|
[(<= label-left-old-pos old-pos)
|
|
(if (<= (+ label-left-old-pos (get-span-from-label label)) old-pos)
|
|
; expression has shrinked, and old-pos was in the part that disappeared,
|
|
; so we make sure the new-pos is at least within the current expression
|
|
; by acting as if old-pos were label-left-old-pos (i.e. moving old-pos
|
|
; to the left end of the expression). Note that this makes old-pos->new-pos
|
|
; not bijective anymore.
|
|
(set! new-pos (+ new-pos
|
|
(- label-left-old-pos old-pos)
|
|
(label-gui-data-total-number-of-snips label-gui-data)))
|
|
; either expression has not shrinked, or if it has, old-pos is sufficiently
|
|
; in the left part that we don't have to worry about it
|
|
(set! new-pos (+ new-pos
|
|
(label-gui-data-total-number-of-snips label-gui-data))))]
|
|
; old-pos is on the left of the expression => do nothing
|
|
)))))
|
|
new-pos))
|
|
|
|
; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
|
|
; Note: the test is "<", because there might a snip that has the exact same
|
|
; position as new-pos, so, since a snip at position n is shown graphically
|
|
; between position n and n+1, we don't want to take that snip into account
|
|
; (i.e. that snip is on the right of the cursor or mouse pointer, not on the
|
|
; left).
|
|
; Note also that we have to be carefull: in old-pos->new-pos we add all the snips
|
|
; to the new-pos when the label has an old-pos to the left of or at the cursor.
|
|
; But here the cursor might be between two snips. So we have to consider each snip
|
|
; separately, we can't consider them group by group anymore.
|
|
(define (new-pos->old-pos gui-model-state new-pos source)
|
|
(let ([old-pos new-pos]
|
|
[get-original-span-from-label
|
|
(gui-model-state-get-original-span-from-label gui-model-state)]
|
|
[get-span-from-label
|
|
(gui-model-state-get-span-from-label gui-model-state)]
|
|
[source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)])
|
|
(when source-gui-data
|
|
(assoc-set-for-each
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)
|
|
(lambda (label label-gui-data)
|
|
(let ([label-left-new-pos (label-gui-data-left-new-pos label-gui-data)]
|
|
[total-number-of-snips (label-gui-data-total-number-of-snips label-gui-data)])
|
|
(cond
|
|
; the order of the clauses is important here
|
|
; new-pos is on the right of the expression represented by the label
|
|
[(<= (+ label-left-new-pos (get-span-from-label label)) new-pos)
|
|
(set! old-pos (- old-pos
|
|
(label-gui-data-span-change label-gui-data)
|
|
(label-gui-data-total-number-of-snips label-gui-data)))]
|
|
; new-pos is somewhere in the middle of the expression represented by the label
|
|
; then we have to take care of the case when the current expression is bigger than
|
|
; the original expression (because an identifier was changed)
|
|
[(<= label-left-new-pos new-pos)
|
|
(if (<= (+ label-left-new-pos (get-original-span-from-label label)) new-pos)
|
|
; expression has expanded, and new-pos was in the part that was added,
|
|
; so we make sure the old-pos is at least within the current expression
|
|
; by acting as if new-pos were label-left-new-pos (i.e. moving new-pos
|
|
; to the left end of the expression). Note that this makes new-pos->old-pos
|
|
; not bijective anymore.
|
|
(set! old-pos (- old-pos
|
|
(- new-pos label-left-new-pos)
|
|
(label-gui-data-total-number-of-snips label-gui-data)))
|
|
; either expression has not expanded, or if it has, new-pos is sufficiently
|
|
; in the left part that we don't have to worry about it
|
|
(set! old-pos (- old-pos
|
|
(label-gui-data-total-number-of-snips label-gui-data))))]
|
|
; new-pos is on the left of the expression but in the middle of the snips
|
|
; at that point we could either loop over the snips groups one by one and test
|
|
; them using their left-new-pos, or we can directly compute the total number of
|
|
; snips on the left of new-pos using the label's left-new-pos and
|
|
; total-number-of-snips. Since the second method is easier, we do it that way.
|
|
[(<= (- label-left-new-pos total-number-of-snips) new-pos)
|
|
(set! old-pos (- old-pos
|
|
(- total-number-of-snips (- label-left-new-pos new-pos))))]
|
|
; new-pos is on the left of the expression and the snips => do nothing
|
|
)))))
|
|
old-pos))
|
|
|
|
; gui-model-state top exact-non-negative-integer exact-integer
|
|
; (exact-non-negative-integer exact-integer -> exact-integer)
|
|
; (exact-non-negative-integer exact-integer -> boolean) -> void
|
|
; moves all snips and arrows that are after start, by len. start is a new position (i.e. after
|
|
; insertion of snips). We need to do all that so that old-pos->new-pos and new-pos->old-pos
|
|
; and the arrow display keep working correctly when we add new snips in the middle of others.
|
|
(define (move-poss gui-model-state source start len add comp)
|
|
(let ([move-pos (lambda (pos) (if (comp pos start) (add pos len) pos))]
|
|
[source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
|
|
(assoc-set-for-each
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)
|
|
(lambda (label label-gui-data)
|
|
(set-label-gui-data-left-new-pos!
|
|
label-gui-data (move-pos (label-gui-data-left-new-pos label-gui-data))))))
|
|
cst:void)
|
|
|
|
|
|
; ARROWS
|
|
; gui-model-state (list label label string) boolean -> void
|
|
; add one arrow going from start-label to end-label, duh.
|
|
(define (add-arrow gui-model-state arrow-info tacked?)
|
|
(let* ([start-label (car arrow-info)]
|
|
[end-label (cadr arrow-info)]
|
|
[new-arrow (make-arrow start-label end-label tacked? (caddr arrow-info))])
|
|
(add-one-arrow-end gui-model-state
|
|
new-arrow
|
|
start-label
|
|
end-label
|
|
arrow-end-label
|
|
label-gui-data-starting-arrows
|
|
(lambda () (set-set (set-make) new-arrow))
|
|
set-make)
|
|
(add-one-arrow-end gui-model-state
|
|
new-arrow
|
|
end-label
|
|
start-label
|
|
arrow-start-label
|
|
label-gui-data-ending-arrows
|
|
set-make
|
|
(lambda () (set-set (set-make) new-arrow)))))
|
|
|
|
; gui-model-state arrow label label (arrow -> label) (label-gui-data -> (setof arrow)
|
|
; (-> (setof arrow)) (-> (setof arrow)) -> void
|
|
; adds arrow structure to the label's gui data, for one end of the arrow
|
|
(define (add-one-arrow-end gui-model-state new-arrow this-end-label other-end-label
|
|
arrow-other-end-label-selector label-gui-data-this-end-arrow-set-selector
|
|
make-starting-arrow-set make-ending-arrow-set)
|
|
(let* ([this-end-source
|
|
((gui-model-state-get-source-from-label gui-model-state) this-end-label)]
|
|
[this-end-source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) this-end-source)]
|
|
[this-end-label-gui-data-by-label
|
|
(source-gui-data-label-gui-data-by-label this-end-source-gui-data)]
|
|
[this-end-label-gui-data
|
|
(assoc-set-get this-end-label-gui-data-by-label this-end-label cst:thunk-false)])
|
|
(if this-end-label-gui-data
|
|
(let* ([this-end-arrow-set
|
|
(label-gui-data-this-end-arrow-set-selector this-end-label-gui-data)]
|
|
[same-arrow-set (set-filter this-end-arrow-set
|
|
(lambda (arrow)
|
|
(eq? other-end-label
|
|
(arrow-other-end-label-selector arrow))))])
|
|
(if (set-empty? same-arrow-set)
|
|
; the arrow doesn't already exist, so add the arrow to the start set
|
|
(set-set this-end-arrow-set new-arrow)
|
|
; the arrow already exists
|
|
(let* ([new-arrow-tacked? (arrow-tacked? new-arrow)]
|
|
[old-arrow (if (= (set-cardinality same-arrow-set) 1)
|
|
(car (set-map same-arrow-set cst:id))
|
|
(error 'add-one-arrow-end "duplicate arrows"))]
|
|
[old-arrow-tacked? (arrow-tacked? old-arrow)])
|
|
(if new-arrow-tacked?
|
|
(if old-arrow-tacked?
|
|
(error 'add-one-arrow-end "tacked arrow already exists")
|
|
(error 'add-one-arrow-end "can't tack arrow over untacked one"))
|
|
(if old-arrow-tacked?
|
|
cst:void ; happens when moving mouse over label with tacked arrows
|
|
(error 'add-one-arrow-end "untacked arrow already exists"))))))
|
|
(assoc-set-set this-end-label-gui-data-by-label
|
|
this-end-label
|
|
(make-label-gui-data (get-new-pos-from-label gui-model-state this-end-label)
|
|
0
|
|
0
|
|
(assoc-set-make)
|
|
(make-starting-arrow-set)
|
|
(make-ending-arrow-set)))))
|
|
cst:void)
|
|
|
|
; gui-model-state label (or/c symbol boolean) boolean -> void
|
|
; remove arrows starting at given label AND arrows ending at same given label
|
|
; Note that assoc-set-get will fail if we try to remove non-existant arrows...
|
|
(define (remove-arrows gui-model-state start-label tacked? exn?)
|
|
(let* ([source-gui-data-by-source
|
|
(gui-model-state-source-gui-data-by-source gui-model-state)]
|
|
[get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
|
|
[source (get-source-from-label start-label)]
|
|
[source-gui-data (assoc-set-get source-gui-data-by-source source)]
|
|
[label-gui-data-by-label
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)]
|
|
[start-label-gui-data
|
|
(if exn?
|
|
(assoc-set-get label-gui-data-by-label start-label)
|
|
(assoc-set-get label-gui-data-by-label start-label cst:thunk-false))])
|
|
; at this point, if the key was not found, either exn? was true and an exception
|
|
; was raised, or it was false and start-label-gui-data is false
|
|
(when start-label-gui-data
|
|
(remove-both-ends source-gui-data-by-source
|
|
(label-gui-data-starting-arrows start-label-gui-data)
|
|
tacked?
|
|
arrow-end-label
|
|
label-gui-data-ending-arrows
|
|
get-source-from-label)
|
|
(remove-both-ends source-gui-data-by-source
|
|
(label-gui-data-ending-arrows start-label-gui-data)
|
|
tacked?
|
|
arrow-start-label
|
|
label-gui-data-starting-arrows
|
|
get-source-from-label)))
|
|
cst:void)
|
|
|
|
; (assoc-setof top source-gui-data) (setof arrow) (or/c symbol boolean)
|
|
; (arrow -> label) (label-gui-data -> (setof arrow))
|
|
; (label -> top)
|
|
; -> (setof arrow)
|
|
; remove arrows starting at given label OR arrows ending at given
|
|
; label (depending on selectors/settors)
|
|
; the result is thrown away by the caller...
|
|
(define (remove-both-ends source-gui-data-by-source set tacked?
|
|
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
|
|
get-source-from-label)
|
|
(if (eq? tacked? 'all)
|
|
; remove all the other ends and reset this end
|
|
; we could do without this case and use the set-filter way used in the "else" case
|
|
; of this if, but doing it that way here is faster because we don't bother testing
|
|
; and removing each arrow from the set one by one, we just reset the whole thing.
|
|
(begin
|
|
(set-for-each set (lambda (arrow)
|
|
(remove-other-end source-gui-data-by-source arrow
|
|
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
|
|
get-source-from-label)))
|
|
(set-reset set))
|
|
; remove other end while filtering this set
|
|
(set-filter set
|
|
(lambda (arrow)
|
|
(if (eq? tacked? (arrow-tacked? arrow))
|
|
(begin
|
|
(remove-other-end source-gui-data-by-source arrow
|
|
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
|
|
get-source-from-label)
|
|
#f)
|
|
#t))
|
|
'same)))
|
|
|
|
; (assoc-setof top source-gui-data) arrow (arrow -> label) (label-gui-data -> (setof arrow))
|
|
; (label -> top) -> (setof arrow)
|
|
; removes one arrow structure reference corresponding to the remote end of the arrow we
|
|
; are removing in remove-both-ends above. We know the arrow is there, so no need to test
|
|
; whether label-gui-data-by-source-and-label and label-gui-data-by-label are false or not.
|
|
; the result is thrown away by the caller...
|
|
(define (remove-other-end source-gui-data-by-source arrow
|
|
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
|
|
get-source-from-label)
|
|
(let* ([other-end-label (arrow-other-end-label-selector arrow)]
|
|
[other-end-source (get-source-from-label other-end-label)]
|
|
[other-end-source-gui-data
|
|
(assoc-set-get source-gui-data-by-source other-end-source)]
|
|
[other-end-label-gui-data
|
|
(assoc-set-get (source-gui-data-label-gui-data-by-label other-end-source-gui-data)
|
|
other-end-label)]
|
|
[other-end-arrow-set (label-gui-data-other-end-arrow-set-selector other-end-label-gui-data)])
|
|
(set-remove other-end-arrow-set arrow)))
|
|
|
|
; gui-model-state -> void
|
|
; remove all arrows in all sources
|
|
; This is faster than looping over each source and then each label in each source and
|
|
; then removing each arrow one by one for each label using remove-arrows.
|
|
(define (remove-all-arrows gui-model-state)
|
|
(let ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
|
|
(assoc-set-for-each
|
|
source-gui-data-by-source
|
|
(lambda (source source-gui-data)
|
|
(assoc-set-for-each
|
|
(source-gui-data-label-gui-data-by-label source-gui-data)
|
|
(lambda (label label-gui-data)
|
|
(set-reset (label-gui-data-starting-arrows label-gui-data))
|
|
(set-reset (label-gui-data-ending-arrows label-gui-data)))))))
|
|
cst:void)
|
|
|
|
; gui-model-state
|
|
; (non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer top top boolean string -> void)
|
|
; -> void
|
|
; applies f to each arrow. The args for f are: the left new-pos of the start label, the
|
|
; left new-pos of the end label, the corresponding spans, the start and end sources,
|
|
; whether the arrow is tacked or not, and the color.
|
|
(define (for-each-arrow gui-model-state f)
|
|
(let ([get-span-from-label (gui-model-state-get-span-from-label gui-model-state)]
|
|
[get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
|
|
[source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
|
|
(assoc-set-for-each
|
|
source-gui-data-by-source
|
|
(lambda (start-source start-source-gui-data)
|
|
(let ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label start-source-gui-data)])
|
|
(assoc-set-for-each
|
|
label-gui-data-by-label
|
|
(lambda (start-label start-label-gui-data)
|
|
(set-for-each (label-gui-data-starting-arrows start-label-gui-data)
|
|
(lambda (arrow)
|
|
(let* ([end-label (arrow-end-label arrow)]
|
|
[end-source (get-source-from-label end-label)]
|
|
[end-source-gui-data ; the arrow exists, so this is not #f
|
|
(assoc-set-get source-gui-data-by-source end-source)]
|
|
[end-label-gui-data-by-label
|
|
(source-gui-data-label-gui-data-by-label end-source-gui-data)]
|
|
[end-label-gui-data
|
|
(assoc-set-get end-label-gui-data-by-label end-label)])
|
|
(f (label-gui-data-left-new-pos start-label-gui-data)
|
|
(label-gui-data-left-new-pos end-label-gui-data)
|
|
(get-span-from-label start-label)
|
|
(get-span-from-label end-label)
|
|
start-source
|
|
end-source
|
|
(arrow-tacked? arrow)
|
|
(arrow-color arrow)))))))))))
|
|
cst:void)
|
|
|
|
; (gui-model-state label -> non-negative-exact-integer)
|
|
; counts how many arrows starting or ending at a given label are tacked
|
|
(define (get-tacked-arrows-from-label gui-model-state label)
|
|
(let ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
((gui-model-state-get-source-from-label gui-model-state) label)
|
|
cst:thunk-false)])
|
|
(if source-gui-data
|
|
(let* ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
|
|
[label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(+ (set-cardinality (set-filter (label-gui-data-starting-arrows label-gui-data) arrow-tacked?))
|
|
(set-cardinality (set-filter (label-gui-data-ending-arrows label-gui-data) arrow-tacked?)))
|
|
0))
|
|
0)))
|
|
|
|
|
|
; SNIPS
|
|
; gui-model-state (symbol -> void) -> void
|
|
; applies f to each type of snips (not the snips themselves, just the types).
|
|
(define (for-each-snip-type gui-model-state f)
|
|
(for-each f (gui-model-state-snip-type-list gui-model-state)))
|
|
|
|
; gui-model-state label symbol -> boolean
|
|
; does the label have snips of a given type currently displayed by the gui?
|
|
(define (label-has-snips-of-this-type? gui-model-state label type)
|
|
(let ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
((gui-model-state-get-source-from-label gui-model-state) label)
|
|
cst:thunk-false)])
|
|
(if source-gui-data
|
|
(let ([label-gui-data
|
|
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
|
|
label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(assoc-set-in? (label-gui-data-snip-groups-by-type label-gui-data) type)
|
|
#f))
|
|
#f)))
|
|
|
|
; (assoc-setof symbol snip-group) symbol (listof symbol) -> non-negative-exact-integer
|
|
; counts how many snips are currently displayed on the right of the position where
|
|
; the snips of the given type currently are or would be displayed
|
|
(define (get-number-of-snips-on-right-from-type snip-groups-by-type type snip-type-list)
|
|
(let ([snip-types-on-right
|
|
(let ([types (memq type snip-type-list)])
|
|
(if types
|
|
types
|
|
(error 'get-number-of-snips-on-right-from-type
|
|
"unknown snip type: ~a" type)))])
|
|
(let loop ([snip-types-on-right (cdr snip-types-on-right)]
|
|
[number-of-snips-on-right 0])
|
|
(if (null? snip-types-on-right)
|
|
number-of-snips-on-right
|
|
(loop (cdr snip-types-on-right)
|
|
(+ number-of-snips-on-right
|
|
(let ([snip-group (assoc-set-get snip-groups-by-type (car snip-types-on-right) cst:thunk-false)])
|
|
(if snip-group
|
|
(snip-group-size snip-group)
|
|
0))))))))
|
|
|
|
; gui-model-state label symbol top non-negative-exact-integer -> non-negative-exact-integer
|
|
; updates state (move existing snips and add new ones) and returns the position where
|
|
; the snips should be inserted in the text
|
|
(define (add-snips gui-model-state label type source number-of-snips)
|
|
(let* ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)]
|
|
[label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
|
|
[label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
|
|
(set-source-gui-data-total-number-of-snips!
|
|
source-gui-data (+ (source-gui-data-total-number-of-snips source-gui-data) number-of-snips))
|
|
(if label-gui-data
|
|
; the label might already have some snips attached to it.
|
|
(let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
|
|
[label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
|
|
[insertion-starting-pos
|
|
(- label-starting-pos
|
|
(get-number-of-snips-on-right-from-type
|
|
snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
|
|
(move-poss gui-model-state source insertion-starting-pos number-of-snips + >=)
|
|
(if (assoc-set-in? snip-groups-by-type type)
|
|
; type already present, but, for a given label and type, we can have only one
|
|
; group of snips
|
|
(error 'add-snips gui-model-state
|
|
"snips-and-arrows internal error; label ~a has already a snip group of type ~a"
|
|
label type)
|
|
; new snip type for this label
|
|
(begin
|
|
(assoc-set-set snip-groups-by-type type (make-snip-group number-of-snips))
|
|
(set-label-gui-data-total-number-of-snips!
|
|
label-gui-data
|
|
(+ (label-gui-data-total-number-of-snips label-gui-data) number-of-snips))))
|
|
insertion-starting-pos)
|
|
; create new label-gui-data for that label
|
|
(let ([label-starting-pos (get-new-pos-from-label gui-model-state label)])
|
|
(move-poss gui-model-state source label-starting-pos number-of-snips + >=)
|
|
(assoc-set-set label-gui-data-by-label
|
|
label
|
|
(make-label-gui-data (+ label-starting-pos number-of-snips)
|
|
0
|
|
number-of-snips
|
|
(assoc-set-set (assoc-set-make)
|
|
type
|
|
(make-snip-group number-of-snips))
|
|
(set-make)
|
|
(set-make)))
|
|
label-starting-pos))))
|
|
|
|
; gui-model-state label symbol top -> (value non-negative-exact-integer non-negative-exact-integer)
|
|
; removes all snips for a given label and type, move remaining snips, and returns the interval
|
|
; to delete in the editor
|
|
(define (remove-inserted-snips gui-model-state label type source)
|
|
(let* ([source-gui-data
|
|
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
|
|
source cst:thunk-false)]
|
|
[label-gui-data
|
|
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
|
|
label cst:thunk-false)])
|
|
(if label-gui-data
|
|
(let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
|
|
[snip-group (assoc-set-get snip-groups-by-type type cst:thunk-false)])
|
|
(if snip-group
|
|
(let* ([size (snip-group-size snip-group)]
|
|
[label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
|
|
[deletion-ending-pos
|
|
(- label-starting-pos
|
|
(get-number-of-snips-on-right-from-type
|
|
snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
|
|
(assoc-set-remove snip-groups-by-type type)
|
|
(move-poss gui-model-state source deletion-ending-pos size - >=)
|
|
(set-label-gui-data-total-number-of-snips!
|
|
label-gui-data
|
|
(- (label-gui-data-total-number-of-snips label-gui-data)
|
|
size))
|
|
(set-source-gui-data-total-number-of-snips!
|
|
source-gui-data
|
|
(- (source-gui-data-total-number-of-snips source-gui-data)
|
|
size))
|
|
(values (- deletion-ending-pos size) deletion-ending-pos))
|
|
(error 'remove-inserted-snips
|
|
"label ~a has no snip group of type ~a"
|
|
label type)))
|
|
(error 'remove-inserted-snips
|
|
"label ~a has no snip groups at all, let alone of type ~a"
|
|
label type))))
|
|
|
|
)
|