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

Compare commits

base: suzanne.soy:master
Branches Tags
suzanne.soy:master
suzanne.soy:try-fix-popup-glitch
suzanne.soy:doc-changes
suzanne.soy:more-ellipses
suzanne.soy:v6.6
suzanne.soy:v6.5
suzanne.soy:v6.4
suzanne.soy:v6.3
suzanne.soy:v6.2
..
compare: suzanne.soy:v6.6
Branches Tags
suzanne.soy:try-fix-popup-glitch
suzanne.soy:doc-changes
suzanne.soy:more-ellipses
suzanne.soy:master
suzanne.soy:v6.6
suzanne.soy:v6.5
suzanne.soy:v6.4
suzanne.soy:v6.3
suzanne.soy:v6.2

No commits in common. "master" and "v6.6" have entirely different histories.
master ... v6.6

27 changed files with 722 additions and 1451 deletions
Show Stats Expand all files Collapse all files

3
gui-doc/info.rkt
View File

@ -15,8 +15,7 @@
"gui-lib"
"pict-lib"
"racket-doc"
"string-constants-doc"
"xrepl-doc"))
"string-constants-doc"))
(define deps '("base"))
(define update-implies '("gui-lib"))

7
gui-doc/scribblings/framework/keymap.scrbl
View File

@ -19,12 +19,9 @@
@defmethod*[(((get-map-function-table/ht (ht hash?)) hash?))]{
This is a helper function for @method[keymap:aug-keymap<%>
get-map-function-table] that returns a similar result, except it accepts a
get-map-function-table] that returns the same result, except it accepts a
hash-table that it inserts the bindings into. It does not replace any
bindings already in @racket[ht]. The result is different from
@method[keymap:aug-keymap<%> get-map-function-table] only in that
@racket[keymap:aug-keymap<%> get-map-function-table] will remove keybindings
that are also have a prefix (since those keybindings are not active).
bindings already in @racket[ht].
}
}
@defmixin[keymap:aug-keymap-mixin (keymap%) (keymap:aug-keymap<%>)]{

33
gui-doc/scribblings/framework/text.scrbl
View File

@ -268,39 +268,6 @@
preference changes.
}
@definterface[text:ascii-art-enlarge-boxes<%> ()]{
@defmethod[(set-ascii-art-enlarge [e? any/c]) void?]{
Enables or disables the ascii art box enlarging mode based on @racket[e?]'s true value.
}
@defmethod[(get-ascii-art-enlarge) boolean?]{
Returns @racket[#t] if ascii art box enlarging mode is enabled and @racket[#f] otherwise.
}
}
@defmixin[text:ascii-art-enlarge-boxes-mixin (text%) (text:ascii-art-enlarge-boxes<%>)]{
@defmethod[#:mode override (on-local-char [event (is-a?/c key-event%)]) void?]{
When the @method[key-event% get-key-code] method of @racket[event] returns either
@racket['numpad-enter] or @racket[#\return] and
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
@racket[#t], this method handles
the return key by adding an additional line in the containing unicode ascii art
box and moving the insertion point to the first character on the new line that
is in the containing cell.
It does not call the @racket[super] method (in that case).
}
@defmethod[#:mode override (on-default-char [event (is-a?/c key-event%)]) void?]{
When the @method[key-event% get-key-code] method of @racket[event] returns either
a character or symbol that corresponds to the insertion of a single character
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
@racket[#t], this method first makes room in the box and then calls the
@racket[super] method. If the @method[text% get-overwrite-mode] returns
@racket[#f], then it always opens up a column in the box. If @method[text% get-overwrite-mode]
returns @racket[#t], then it opens up a column only when the character to
be inserted would overwrite one of the walls.
}
}
@definterface[text:first-line<%> (text%)]{
Objects implementing this interface, when @method[text:first-line<%>

1
gui-doc/scribblings/gui/gui.scrbl
View File

@ -52,7 +52,6 @@ Both parts of the toolbox rely extensively on the
@include-section["prefs.scrbl"]
@include-section["dynamic.scrbl"]
@include-section["startup.scrbl"]
@include-section["init.scrbl"]
@include-section["libs.scrbl"]
@;------------------------------------------------------------------------

30
gui-doc/scribblings/gui/init.scrbl
View File

@ -1,30 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label racket/gui/dynamic racket/pretty racket/gui/base setup/dirs))
@title{Init Libraries}
@defmodule*/no-declare[(racket/gui/init)]{The
@racketmodname[racket/gui/init] library is the default start-up
library for GRacket. It re-exports the @racketmodname[racket/init] and
@racketmodname[racket/gui/base] libraries, and it sets
@racket[current-load] to use @racket[text-editor-load-handler].}
@defmodule*/no-declare[(racket/gui/interactive)]{
Similar to @racketmodname[racket/interactive], but for
GRacket. This library can be changed by modifying
@racket['gui-interactive-file] in the
@filepath{config.rktd} file in @racket[(find-config-dir)].
Additionally, if the file @filepath{gui-interactive.rkt}
exists in @racket[(find-system-path 'addon-dir)], it is run
rather than the installation wide graphical interactive
module.
This library runs the
@racket[(find-graphical-system-path 'init-file)] file in
the users home directory if it exists, rather than their
@racket[(find-system-path 'init-file)]. Unlike
@racketmodname[racket/interactive], this library does not
start @racketmodname[xrepl].
@history[#:added "1.27"]}

10
gui-doc/scribblings/gui/keymap-class.scrbl
View File

@ -101,13 +101,9 @@ If @racket[try-chain?] is not @racket[#f], keymaps chained to this one
void?]{
Chains @racket[next] off @this-obj[] The @racket[next] keymap will be
used to handle events which are not handled by @this-obj[].
If @racket[prefix?] is a true value, then @racket[next] will take
precedence over other keymaps already chained to @this-obj[] in the
case that both keymaps map the same key sequence.
When one chained keymap maps a key that is a prefix of another, then the
shorter key sequence is always used, regardless of @racket[prefix?].
used to handle events which are not handled by @this-obj[]. If
@racket[prefix?] is a true value, then @racket[next] will take
precedence over other keymaps already chained to @this-obj[].
Multiple keymaps can be chained off one keymap using @method[keymap%
chain-to-keymap]. When keymaps are chained off a main keymap, events

2
gui-doc/scribblings/gui/win-overview.scrbl
View File

@ -998,7 +998,7 @@ animation frame with @method[canvas<%> suspend-flush] and
are not flushed to the screen. Use @method[canvas<%> flush] to ensure
that canvas content is flushed when it is ready if a @method[canvas<%>
suspend-flush] will soon follow, because the process of flushing to
the screen can be starved if flushing is frequently suspended. The
the screen can be starved if flushing is frequently suspend. The
method @xmethod[canvas% refresh-now] conveniently encapsulates this
sequence.

41
gui-lib/framework/private/frame.rkt
View File

@ -1118,29 +1118,6 @@
[define anchor-last-state? #f]
[define overwrite-last-state? #f]
(define/private (update-ascii-art-enlarge-msg)
(define ascii-art-enlarge-mode?
(let ([e (get-info-editor)])
(and (is-a? e text:ascii-art-enlarge-boxes<%>)
(send e get-ascii-art-enlarge))))
(unless (eq? (and (member ascii-art-enlarge-mode-msg (send uncommon-parent get-children)) #t)
ascii-art-enlarge-mode?)
(if ascii-art-enlarge-mode?
(add-uncommon-child ascii-art-enlarge-mode-msg)
(remove-uncommon-child ascii-art-enlarge-mode-msg))))
;; this callback is kind of a hack. we know that when the set-ascii-art-enlarge
;; method of text:ascii-art-enlarge<%> is called that it changes the preferences
;; value so we will get called back here; it would be better if we could just
;; have the callback happen directly by overriding that method, but that causes
;; backwards incompatibility problems.
(define callback (λ (p v)
(queue-callback
(λ () (update-ascii-art-enlarge-msg))
#f)))
(preferences:add-callback 'framework:ascii-art-enlarge callback #t)
(field (macro-recording? #f))
(define/private (update-macro-recording-icon)
@ -1216,7 +1193,6 @@
(define/override (update-info)
(super update-info)
(update-macro-recording-icon)
(update-ascii-art-enlarge-msg)
(overwrite-status-changed)
(anchor-status-changed)
(editor-position-changed)
@ -1257,11 +1233,6 @@
(send (get-info-panel) change-children
(λ (l) (cons uncommon-parent (remq uncommon-parent l))))
(define ascii-art-enlarge-mode-msg (new message%
[parent uncommon-parent]
[label "╠╬╣"]
[auto-resize #t]))
(define anchor-message
(new message%
[font small-control-font]
@ -1283,7 +1254,6 @@
(define/private (add-uncommon-child c)
(define (child->num c)
(cond
[(eq? c ascii-art-enlarge-mode-msg) -1]
[(eq? c anchor-message) 0]
[(eq? c overwrite-message) 1]
[(eq? c macro-recording-message) 2]))
@ -2083,13 +2053,10 @@
(let* ([string (get-text)]
[top-searching-edit (get-searching-text)])
(when top-searching-edit
(let ([searching-edit
(let loop ([txt top-searching-edit])
(define focus-snip (send txt get-focus-snip))
(cond
[(and focus-snip (is-a? focus-snip editor-snip%))
(loop (send focus-snip get-editor))]
[else txt]))]
(let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
(if (and focus-snip (is-a? focus-snip editor-snip%))
(send focus-snip get-editor)
top-searching-edit))]
[not-found
(λ (found-edit skip-beep?)

9
gui-lib/framework/private/interfaces.rkt
View File

@ -9,8 +9,7 @@
frame:basic<%>
frame:standard-menus<%>
frame:info<%>
frame:text-info<%>
text:ascii-art-enlarge-boxes<%>)
frame:text-info<%>)
(define editor:basic<%>
(interface (editor<%>)
@ -33,12 +32,6 @@
(interface (editor:basic<%>)
get-keymaps))
(define text:ascii-art-enlarge-boxes<%>
(interface ()
set-ascii-art-enlarge
get-ascii-art-enlarge))
(define text:basic<%>
(interface (editor:basic<%> (class->interface text%))
highlight-range

353
gui-lib/framework/private/keymap-global.rkt
View File

@ -6,7 +6,6 @@
"interfaces.rkt"
"../preferences.rkt"
"gen-standard-menus.rkt"
"unicode-ascii-art.rkt"
(only-in srfi/13 string-prefix? string-prefix-length)
2d/dir-chars
racket/list)
@ -709,17 +708,6 @@
(define start (send txt get-start-position))
(when (= start (send txt get-end-position))
(widen-unicode-ascii-art-box txt start)))]
[heighten-unicode-ascii-art-box
(λ (txt evt)
(define start (send txt get-start-position))
(when (= start (send txt get-end-position))
(heighten-unicode-ascii-art-box txt start)))]
[toggle-unicode-ascii-art-enlarge-mode
(λ (txt evt)
(when (is-a? txt text:ascii-art-enlarge-boxes<%>)
(send txt set-ascii-art-enlarge (not (send txt get-ascii-art-enlarge)))))]
[center-in-unicode-ascii-art-box
(λ (txt evt)
@ -752,8 +740,6 @@
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
(add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
(add "heighten-unicode-ascii-art-box" heighten-unicode-ascii-art-box)
(add "toggle-unicode-ascii-art-enlarge-mode" toggle-unicode-ascii-art-enlarge-mode)
(add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box)
(add "shift-focus" (shift-focus values))
(add "shift-focus-backwards" (shift-focus reverse))
@ -850,9 +836,7 @@
(map "c:x;r;a" "normalize-unicode-ascii-art-box")
(map "c:x;r;w" "widen-unicode-ascii-art-box")
(map "c:x;r;v" "highten-unicode-ascii-art-box")
(map "c:x;r;c" "center-in-unicode-ascii-art-box")
(map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
(map "~m:c:\\" "TeX compress")
(map "~c:m:\\" "TeX compress")
@ -1043,6 +1027,166 @@
(f click-pos eol start-pos click-pos)
(f click-pos eol click-pos end-pos))))
(define (widen-unicode-ascii-art-box t orig-pos)
(define start-pos (scan-for-start-pos t orig-pos))
(when start-pos
(send t begin-edit-sequence)
(define-values (start-x start-y) (pos->xy t orig-pos))
(define min-y #f)
(define max-y #f)
(trace-unicode-ascii-art-box
t start-pos #f
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
(when (= x start-x)
(unless min-y
(set! min-y y)
(set! max-y y))
(set! min-y (min y min-y))
(set! max-y (max y max-y)))))
(define to-adjust 0)
(for ([y (in-range max-y (- min-y 1) -1)])
(define-values (pos char) (xy->pos t start-x y))
(when (< pos start-pos)
(set! to-adjust (+ to-adjust 1)))
(send t insert
(cond
[(member char lt-chars) #\═]
[else #\space])
pos pos))
(send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))
(send t end-edit-sequence)))
(define (normalize-unicode-ascii-art-box t pos)
(define start-pos (scan-for-start-pos t pos))
(when start-pos
(send t begin-edit-sequence)
(trace-unicode-ascii-art-box
t start-pos #f
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
(cond
[(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
[(and i-dn? i-lt? i-rt?) (set-c t pos "╦")]
[(and i-up? i-lt? i-rt?) (set-c t pos "╩")]
[(and i-up? i-dn? i-rt?) (set-c t pos "╠")]
[(and i-up? i-dn? i-lt?) (set-c t pos "╣")]
[(and i-up? i-lt?) (set-c t pos "╝")]
[(and i-up? i-rt?) (set-c t pos "╚")]
[(and i-dn? i-lt?) (set-c t pos "╗")]
[(and i-dn? i-rt?) (set-c t pos "╔")]
[(or i-up? i-dn?) (set-c t pos "║")]
[else (set-c t pos "═")])))
(send t end-edit-sequence)))
(define (center-in-unicode-ascii-art-box txt insertion-pos)
(define (find-something start-pos inc char-p?)
(define-values (x y) (pos->xy txt start-pos))
(let loop ([pos start-pos])
(cond
[(char-p? (send txt get-character pos))
pos]
[else
(define new-pos (inc pos))
(cond
[(<= 0 new-pos (send txt last-position))
(define-values (x2 y2) (pos->xy txt new-pos))
(cond
[(= y2 y)
(loop new-pos)]
[else #f])]
[else #f])])))
(define (adjust-space before-space after-space pos)
(cond
[(< before-space after-space)
(send txt insert (make-string (- after-space before-space) #\space) pos pos)]
[(> before-space after-space)
(send txt delete pos (+ pos (- before-space after-space)))]))
(define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
(define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
(when (and left-bar right-bar (< left-bar right-bar))
(define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
(define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
(when (and left-space-edge right-space-edge)
(define before-left-space-count (- left-space-edge left-bar 1))
(define before-right-space-count (- right-bar right-space-edge 1))
(define tot-space (+ before-left-space-count before-right-space-count))
(define after-left-space-count (floor (/ tot-space 2)))
(define after-right-space-count (ceiling (/ tot-space 2)))
(send txt begin-edit-sequence)
(adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
(adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
(send txt end-edit-sequence))))
(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
(define visited (make-hash))
(let loop ([pos start-pos])
(unless (hash-ref visited pos #f)
(hash-set! visited pos #t)
(define-values (x y) (pos->xy t pos))
(define c (send t get-character pos))
(define-values (up upc) (xy->pos t x (- y 1)))
(define-values (dn dnc) (xy->pos t x (+ y 1)))
(define-values (lt ltc) (xy->pos t (- x 1) y))
(define-values (rt rtc) (xy->pos t (+ x 1) y))
(define (interesting-dir? dir-c dir-chars)
(or (and (not only-double-barred-chars?)
(member dir-c adjustable-chars)
(member c dir-chars))
(and (member dir-c double-barred-chars)
(member c double-barred-chars))))
(define i-up? (interesting-dir? upc up-chars))
(define i-dn? (interesting-dir? dnc dn-chars))
(define i-lt? (interesting-dir? ltc lt-chars))
(define i-rt? (interesting-dir? rtc rt-chars))
(f pos x y i-up? i-dn? i-lt? i-rt?)
(when i-up? (loop up))
(when i-dn? (loop dn))
(when i-lt? (loop lt))
(when i-rt? (loop rt)))))
(define (scan-for-start-pos t pos)
(define-values (x y) (pos->xy t pos))
(findf
(λ (p) (adj? t p))
(for*/list ([xadj '(0 -1)]
[yadj '(0 -1 1)])
(define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
d)))
(define (adj? t pos)
(and pos
(member (send t get-character pos)
adjustable-chars)))
(define (set-c t pos s)
(unless (equal? (string-ref s 0) (send t get-character pos))
(send t delete pos (+ pos 1))
(send t insert s pos pos)))
(define (pos->xy text pos)
(define para (send text position-paragraph pos))
(define start (send text paragraph-start-position para))
(values (- pos start) para))
(define (xy->pos text x y)
(cond
[(and (<= 0 x) (<= 0 y (send text last-paragraph)))
(define para-start (send text paragraph-start-position y))
(define para-end (send text paragraph-end-position y))
(define pos (+ para-start x))
(define res-pos
(and (< pos para-end)
;; the newline at the end of the
;; line is not on the line, so use this guard
pos))
(if res-pos
(values res-pos (send text get-character res-pos))
(values #f #f))]
[else (values #f #f)]))
(define/contract (run-some-keystrokes before key-evts)
(-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?)
(listof (is-a?/c key-event%))
@ -1060,7 +1204,182 @@
(send t get-end-position)))
(module+ test
(require rackunit)
(require rackunit
racket/gui/base)
(define sa string-append)
(define (first-value-xy->pos a b c)
(define-values (d e) (xy->pos a b c))
d)
(let ([t (new text%)])
(send t insert (sa "abc\n"
"d\n"
"ghi\n"))
(check-equal? (first-value-xy->pos t 0 0) 0)
(check-equal? (first-value-xy->pos t 1 0) 1)
(check-equal? (first-value-xy->pos t 0 1) 4)
(check-equal? (first-value-xy->pos t 3 0) #f)
(check-equal? (first-value-xy->pos t 0 3) #f)
(check-equal? (first-value-xy->pos t 1 1) #f)
(check-equal? (first-value-xy->pos t 2 1) #f)
(check-equal? (first-value-xy->pos t 0 2) 6)
(check-equal? (first-value-xy->pos t 1 2) 7)
(check-equal? (first-value-xy->pos t 2 -1) #f)
(check-equal? (first-value-xy->pos t -1 0) #f)
(check-equal? (first-value-xy->pos t 2 2) 8)
(check-equal? (first-value-xy->pos t 2 3) #f))
(let ([t (new text%)])
(send t insert (sa "abc\n"
"d\n"
"ghi"))
(check-equal? (first-value-xy->pos t 2 2) 8)
(check-equal? (first-value-xy->pos t 2 3) #f))
(let ([t (new text%)])
(send t insert (string-append "+-+\n"
"| |\n"
"+-+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
"║ ║\n"
"╚═╝\n")))
(let ([t (new text%)])
(send t insert (string-append "+=+\n"
"| |\n"
"+=+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
"║ ║\n"
"╚═╝\n")))
(let ([t (new text%)])
(send t insert (string-append "+-+-+\n"
"| | |\n"
"+-+-+\n"
"| | |\n"
"+-+-+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═══╗\n"
"║ - ║\n"
"╚═══╝\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═══╗\n"
"║ - ║\n"
"╚═══╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 1 1)
(widen-unicode-ascii-art-box t 1)
(check-equal? (send t get-start-position) 2)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 8 8)
(widen-unicode-ascii-art-box t 8)
(check-equal? (send t get-start-position) 10)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"))
(send t set-position 8 8)
(widen-unicode-ascii-art-box t 8)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n")))
(let ([t (new text%)])
(send t insert "║ x ║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║x ║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║ x║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║abcde║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║abcde║\n"))
(let ([t (new text%)])
(send t insert "║║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║║\n"))
(let ([t (new text%)])
(send t insert "║abcde \n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║abcde \n"))
(let ([t (new text%)])
(send t insert " abcde║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
" abcde║\n"))
(check-equal? (run-some-keystrokes '("abc" 0 0)
(list (new key-event% [key-code 'escape])
(new key-event% [key-code #\c])))

33
gui-lib/framework/private/keymap.rkt
View File

@ -148,38 +148,7 @@
(hash-set! function-table (string->symbol keyname) fname))
(define/public (get-map-function-table)
(define table-possibly-with-prefixes (get-map-function-table/ht (make-hasheq)))
(define trie (make-hash))
(define (add-to-trie loks name)
(let loop ([trie trie]
[loks loks])
(cond
[(null? (cdr loks))
(hash-set! trie (car loks) name)]
[else
(define sub (hash-ref trie (car loks)
(λ ()
(define h (make-hash))
(hash-set! trie (car loks) h)
h)))
(loop sub (cdr loks))])))
(for ([(canonicalized-symbol keyname) (in-hash table-possibly-with-prefixes)])
(define keys (regexp-split #rx";" (symbol->string canonicalized-symbol)))
(add-to-trie keys keyname))
(define table-without-prefixes (make-hash))
(let loop ([trie trie]
[prefix '()])
(cond
[(string? trie)
(define keystring (string->symbol (join-strings ";" (reverse prefix))))
(hash-set! table-without-prefixes keystring trie)]
[else (for ([(key sub-trie) (in-hash trie)])
(loop sub-trie (cons key prefix)))]))
table-without-prefixes)
(get-map-function-table/ht (make-hasheq)))
(define/public (get-map-function-table/ht table)
(for ([(keyname fname) (in-hash function-table)])

2
gui-lib/framework/private/main.rkt
View File

@ -25,8 +25,6 @@
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:ascii-art-enlarge #f boolean?)
(preferences:set-default 'framework:color-scheme 'classic symbol?)
(preferences:set-default 'framework:column-guide-width

376
gui-lib/framework/private/racket.rkt
View File

@ -504,6 +504,12 @@
[else
(+ i 1)])))
(public tabify-all insert-return calc-last-para
box-comment-out-selection comment-out-selection uncomment-selection
flash-forward-sexp
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
remove-parens-forward)
(define/public (get-limit pos) 0)
(define/public (balance-parens key-event [smart-skip #f])
@ -771,7 +777,6 @@
(unless (is-stopped?)
(define first-para (position-paragraph start-pos))
(define end-para (position-paragraph end-pos))
(define tabifying-multiple-paras? (not (= first-para end-para)))
(with-handlers ([exn:break?
(λ (x) #t)])
(dynamic-wind
@ -782,14 +787,7 @@
(λ ()
(let loop ([para first-para])
(when (<= para end-para)
(define start (paragraph-start-position para))
(define end (paragraph-end-position para))
(define skip-this-line?
(and tabifying-multiple-paras?
(for/and ([i (in-range start (+ end 1))])
(char-whitespace? (get-character i)))))
(unless skip-this-line?
(tabify start))
(tabify (paragraph-start-position para))
(parameterize-break #t (void))
(loop (add1 para))))
(when (and (>= (position-paragraph start-pos) end-para)
@ -807,8 +805,8 @@
(when (< first-para end-para)
(end-busy-cursor)))))))
(define/public (tabify-all) (tabify-selection 0 (last-position)))
(define/public (insert-return)
(define (tabify-all) (tabify-selection 0 (last-position)))
(define (insert-return)
(begin-edit-sequence #t #f)
(define end-of-whitespace (get-start-position))
(define start-cutoff
@ -832,7 +830,7 @@
new-pos))))
(end-edit-sequence))
(define/public (calc-last-para last-pos)
(define (calc-last-para last-pos)
(let ([last-para (position-paragraph last-pos #t)])
(if (and (> last-pos 0)
(> last-para 0))
@ -843,53 +841,55 @@
last-para)))
last-para)))
(define/public (comment-out-selection [start-pos (get-start-position)]
[end-pos (get-end-position)])
(begin-edit-sequence)
(let ([first-pos-is-first-para-pos?
(= (paragraph-start-position (position-paragraph start-pos))
start-pos)])
(let* ([first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(when (<= curr-para last-para)
(let ([first-on-para (paragraph-start-position curr-para)])
(insert #\; first-on-para)
(para-loop (add1 curr-para))))))
(when first-pos-is-first-para-pos?
(set-position
(paragraph-start-position (position-paragraph (get-start-position)))
(get-end-position))))
(end-edit-sequence)
#t)
(define comment-out-selection
(lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)])
(begin-edit-sequence)
(let ([first-pos-is-first-para-pos?
(= (paragraph-start-position (position-paragraph start-pos))
start-pos)])
(let* ([first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(when (<= curr-para last-para)
(let ([first-on-para (paragraph-start-position curr-para)])
(insert #\; first-on-para)
(para-loop (add1 curr-para))))))
(when first-pos-is-first-para-pos?
(set-position
(paragraph-start-position (position-paragraph (get-start-position)))
(get-end-position))))
(end-edit-sequence)
#t))
(define/public (box-comment-out-selection [_start-pos 'start]
[_end-pos 'end])
(let ([start-pos (if (eq? _start-pos 'start)
(get-start-position)
_start-pos)]
[end-pos (if (eq? _end-pos 'end)
(get-end-position)
_end-pos)])
(begin-edit-sequence)
(split-snip start-pos)
(split-snip end-pos)
(let* ([cb (instantiate comment-box:snip% ())]
[text (send cb get-editor)])
(let loop ([snip (find-snip start-pos 'after-or-none)])
(cond
[(not snip) (void)]
[((get-snip-position snip) . >= . end-pos) (void)]
[else
(send text insert (send snip copy)
(send text last-position)
(send text last-position))
(loop (send snip next))]))
(delete start-pos end-pos)
(insert cb start-pos)
(set-position start-pos start-pos))
(end-edit-sequence)
#t))
(define box-comment-out-selection
(lambda ([_start-pos 'start]
[_end-pos 'end])
(let ([start-pos (if (eq? _start-pos 'start)
(get-start-position)
_start-pos)]
[end-pos (if (eq? _end-pos 'end)
(get-end-position)
_end-pos)])
(begin-edit-sequence)
(split-snip start-pos)
(split-snip end-pos)
(let* ([cb (instantiate comment-box:snip% ())]
[text (send cb get-editor)])
(let loop ([snip (find-snip start-pos 'after-or-none)])
(cond
[(not snip) (void)]
[((get-snip-position snip) . >= . end-pos) (void)]
[else
(send text insert (send snip copy)
(send text last-position)
(send text last-position))
(loop (send snip next))]))
(delete start-pos end-pos)
(insert cb start-pos)
(set-position start-pos start-pos))
(end-edit-sequence)
#t)))
;; uncomment-box/selection : -> void
;; uncomments a comment box, if the focus is inside one.
@ -909,43 +909,44 @@
(end-edit-sequence)
#t)
(define/public (uncomment-selection [start-pos (get-start-position)]
[end-pos (get-end-position)])
(let ([snip-before (find-snip start-pos 'before-or-none)]
[snip-after (find-snip start-pos 'after-or-none)])
(define uncomment-selection
(lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)])
(let ([snip-before (find-snip start-pos 'before-or-none)]
[snip-after (find-snip start-pos 'after-or-none)])
(begin-edit-sequence)
(cond
[(and (= start-pos end-pos)
snip-before
(is-a? snip-before comment-box:snip%))
(extract-contents start-pos snip-before)]
[(and (= start-pos end-pos)
snip-after
(is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)]
[(and (= (+ start-pos 1) end-pos)
snip-after
(is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)]
[else
(let* ([last-pos (last-position)]
[first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(when (<= curr-para last-para)
(let ([first-on-para
(skip-whitespace (paragraph-start-position curr-para)
'forward
#f)])
(split-snip first-on-para)
(when (and (< first-on-para last-pos)
(char=? #\; (get-character first-on-para))
(is-a? (find-snip first-on-para 'after-or-none) string-snip%))
(delete first-on-para (+ first-on-para 1)))
(para-loop (add1 curr-para))))))])
(end-edit-sequence))
#t)
(begin-edit-sequence)
(cond
[(and (= start-pos end-pos)
snip-before
(is-a? snip-before comment-box:snip%))
(extract-contents start-pos snip-before)]
[(and (= start-pos end-pos)
snip-after
(is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)]
[(and (= (+ start-pos 1) end-pos)
snip-after
(is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)]
[else
(let* ([last-pos (last-position)]
[first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(when (<= curr-para last-para)
(let ([first-on-para
(skip-whitespace (paragraph-start-position curr-para)
'forward
#f)])
(split-snip first-on-para)
(when (and (< first-on-para last-pos)
(char=? #\; (get-character first-on-para))
(is-a? (find-snip first-on-para 'after-or-none) string-snip%))
(delete first-on-para (+ first-on-para 1)))
(para-loop (add1 curr-para))))))])
(end-edit-sequence))
#t))
;; extract-contents : number (is-a?/c comment-box:snip%) -> void
;; copies the contents of the comment-box-snip out of the snip
@ -1023,12 +1024,13 @@
(set-position end-pos)
(bell))
#t))
(define/public (flash-forward-sexp start-pos)
(let ([end-pos (get-forward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))
[define flash-forward-sexp
(λ (start-pos)
(let ([end-pos (get-forward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))]
(define/public (get-backward-sexp start-pos)
(let* ([limit (get-limit start-pos)]
[end-pos (backward-match start-pos limit)]
@ -1047,82 +1049,89 @@
end-pos)))
;; can't go backward at all:
#f)))
(define/public (flash-backward-sexp start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))
(define/public (backward-sexp start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(set-position end-pos)
(bell))
#t))
(define/public (find-up-sexp start-pos)
(let* ([limit-pos (get-limit start-pos)]
[exp-pos
(backward-containing-sexp start-pos limit-pos)])
[define flash-backward-sexp
(λ (start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))]
[define backward-sexp
(λ (start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(set-position end-pos)
(bell))
#t))]
[define find-up-sexp
(λ (start-pos)
(let* ([limit-pos (get-limit start-pos)]
[exp-pos
(backward-containing-sexp start-pos limit-pos)])
(if (and exp-pos (> exp-pos limit-pos))
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
[paren-pos
(λ (paren-pair)
(find-string
(car paren-pair)
'backward
in-start-pos
limit-pos))])
(let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
(cond
[(null? parens) null]
[else
(let ([pos (paren-pos (car parens))])
(if pos
(cons pos (loop (cdr parens)))
(loop (cdr parens))))]))])
(if (null? poss) ;; all finds failed
#f
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
#f)))
(define/public (up-sexp start-pos)
(let ([exp-pos (find-up-sexp start-pos)])
(if exp-pos
(set-position exp-pos)
(bell))
#t))
(define/public (find-down-sexp start-pos)
(let loop ([pos start-pos])
(let ([next-pos (get-forward-sexp pos)])
(if (and next-pos (> next-pos pos))
(let ([back-pos
(backward-containing-sexp (sub1 next-pos) pos)])
(if (and back-pos
(> back-pos pos))
back-pos
(loop next-pos)))
#f))))
(define/public (down-sexp start-pos)
(let ([pos (find-down-sexp start-pos)])
(if pos
(set-position pos)
(bell))
#t))
(define/public (remove-parens-forward start-pos)
(let* ([pos (skip-whitespace start-pos 'forward #f)]
[first-char (get-character pos)]
[paren? (or (char=? first-char #\()
(char=? first-char #\[)
(char=? first-char #\{))]
[closer (and paren?
(get-forward-sexp pos))])
(if (and paren? closer)
(begin (begin-edit-sequence #t #f)
(delete pos (add1 pos))
(delete (- closer 2) (- closer 1))
(end-edit-sequence))
(bell))
#t))
(if (and exp-pos (> exp-pos limit-pos))
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
[paren-pos
(λ (paren-pair)
(find-string
(car paren-pair)
'backward
in-start-pos
limit-pos))])
(let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
(cond
[(null? parens) null]
[else
(let ([pos (paren-pos (car parens))])
(if pos
(cons pos (loop (cdr parens)))
(loop (cdr parens))))]))])
(if (null? poss) ;; all finds failed
#f
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
#f)))]
[define up-sexp
(λ (start-pos)
(let ([exp-pos (find-up-sexp start-pos)])
(if exp-pos
(set-position exp-pos)
(bell))
#t))]
[define find-down-sexp
(λ (start-pos)
(let loop ([pos start-pos])
(let ([next-pos (get-forward-sexp pos)])
(if (and next-pos (> next-pos pos))
(let ([back-pos
(backward-containing-sexp (sub1 next-pos) pos)])
(if (and back-pos
(> back-pos pos))
back-pos
(loop next-pos)))
#f))))]
[define down-sexp
(λ (start-pos)
(let ([pos (find-down-sexp start-pos)])
(if pos
(set-position pos)
(bell))
#t))]
[define remove-parens-forward
(λ (start-pos)
(let* ([pos (skip-whitespace start-pos 'forward #f)]
[first-char (get-character pos)]
[paren? (or (char=? first-char #\()
(char=? first-char #\[)
(char=? first-char #\{))]
[closer (and paren?
(get-forward-sexp pos))])
(if (and paren? closer)
(begin (begin-edit-sequence #t #f)
(delete pos (add1 pos))
(delete (- closer 2) (- closer 1))
(end-edit-sequence))
(bell))
#t))]
(define/private (select-text f forward?)
(define start-pos (get-start-position))
@ -1139,11 +1148,11 @@
(extend-position new-pos)
(bell))
#t)
(define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t))
(define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f))
(define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f))
(define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t))
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
[define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
[define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
[define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
[define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
(define/public (introduce-let-ans pos)
(dynamic-wind
@ -1289,9 +1298,10 @@
(for-each (λ (s) (insert s start-1)) snips-2/rev)
(set-position end-2)
(end-edit-sequence)))))))))))
(define tab-size 8)
(define/public (get-tab-size) tab-size)
(define/public (set-tab-size s) (set! tab-size s))
[define tab-size 8]
(public get-tab-size set-tab-size)
[define get-tab-size (λ () tab-size)]
[define set-tab-size (λ (s) (set! tab-size s))]
(define/override (get-start-of-line pos)
(define para (position-paragraph pos))

207
gui-lib/framework/private/search.rkt
View File

@ -1,116 +1,99 @@
#lang racket/base
#lang scheme/base
(require racket/contract/base
racket/class
racket/gui/base)
scheme/gui/base)
(provide
(contract-out
[find-string-embedded
(->* ((is-a?/c text%)
string?)
((or/c 'forward 'backward)
(or/c 'start number?)
(or/c 'eof number?)
boolean?
boolean?
boolean?)
(values (is-a?/c editor<%>)
(or/c #f number?)))]))
(provide/contract
[find-string-embedded
(->* ((is-a?/c text%)
string?)
((symbols 'forward 'backward)
(or/c (symbols 'start) number?)
(or/c (symbols 'eof) number?)
boolean?
boolean?
boolean?)
(values (is-a?/c editor<%>)
(or/c false/c number?)))])
(define (find-string-embedded a-text
str
[direction 'forward]
[start 'start]
[end 'eof]
[get-start #t]
[case-sensitive? #t]
[pop-out? #f])
(let/ec k
(let loop ([a-text a-text]
[start start]
[end end])
(define found (send a-text find-string-embedded str direction start end get-start case-sensitive?))
(define (done)
(cond
[(not found)
(k a-text found)]
[else
(let loop ([a-text a-text]
[found found])
(cond
[(number? found)
(k a-text found)]
[else (loop (car found) (cdr found))]))]))
(when found (done))
(unless pop-out? (done))
(define a-text-admin (send a-text get-admin))
(unless (is-a? a-text-admin editor-snip-editor-admin<%>) (done))
(define editor-snip (send a-text-admin get-snip))
(define editor-snip-admin (send editor-snip get-admin))
(unless editor-snip-admin (done))
(define enclosing-text (send editor-snip-admin get-editor))
(unless (is-a? enclosing-text text%) (done))
(loop enclosing-text
(+ (send enclosing-text get-snip-position editor-snip)
(send editor-snip get-count))
'eof))))
(module+ test
(require rackunit)
(define abcX (new text%))
(send abcX insert "abcX")
(define abc/abcX/abcQ (new text%))
(send abc/abcX/abcQ insert "abc")
(send abc/abcX/abcQ insert (new editor-snip% [editor abcX]))
(send abc/abcX/abcQ insert "abcQ")
(define abc//abc/abcX/abcQ//abcZ (new text%))
(send abc//abc/abcX/abcQ//abcZ insert "abc")
(send abc//abc/abcX/abcQ//abcZ insert (new editor-snip% [editor abc/abcX/abcQ]))
(send abc//abc/abcX/abcQ//abcZ insert "abcZ")
(let ()
(define-values (ta pos) (find-string-embedded abcX "b" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 2))
(let ()
(define-values (ta pos) (find-string-embedded abcX "d" 'forward 2))
(check-equal? pos #f))
(let ()
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0))
(check-equal? ta ta)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2))
(check-equal? ta abcX)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 3))
(let ()
(define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t))
(check-equal? ta abc/abcX/abcQ)
(check-equal? pos 7))
(let ()
(define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t))
(check-equal? ta abc//abc/abcX/abcQ//abcZ)
(check-equal? pos 7))
(let ()
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t))
(check-equal? ta abc/abcX/abcQ)
(check-equal? pos 6)))
(define find-string-embedded
(lambda (edit
str
[direction 'forward]
[start 'start]
[end 'eof]
[get-start #t]
[case-sensitive? #t]
[pop-out? #f])
(let/ec k
(let* ([start (if (eq? start 'start)
(send edit get-start-position)
start)]
[end (if (eq? 'eof end)
(if (eq? direction 'forward)
(send edit last-position)
0)
end)]
[flat (send edit find-string str direction
start end get-start
case-sensitive?)]
[pop-out
(λ ()
(let ([admin (send edit get-admin)])
(if (is-a? admin editor-snip-editor-admin<%>)
(let* ([snip (send admin get-snip)]
[edit-above (send (send snip get-admin) get-editor)]
[pos (send edit-above get-snip-position snip)]
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
(find-string-embedded
edit-above
str
direction
pop-out-pos
(if (eq? direction 'forward) 'eof 0)
get-start
case-sensitive?
pop-out?))
(values edit #f))))])
(let loop ([current-snip (send edit find-snip start
(if (eq? direction 'forward)
'after-or-none
'before-or-none))])
(let ([next-loop
(λ ()
(if (eq? direction 'forward)
(loop (send current-snip next))
(loop (send current-snip previous))))])
(cond
[(or (not current-snip)
(and flat
(let* ([start (send edit get-snip-position current-snip)]
[end (+ start (send current-snip get-count))])
(if (eq? direction 'forward)
(and (<= start flat)
(< flat end))
(and (< start flat)
(<= flat end))))))
(if (and (not flat) pop-out?)
(pop-out)
(values edit flat))]
[(is-a? current-snip editor-snip%)
(let-values ([(embedded embedded-pos)
(let ([media (send current-snip get-editor)])
(if (and media
(is-a? media text%))
(begin
(find-string-embedded
media
str
direction
(if (eq? 'forward direction)
0
(send media last-position))
'eof
get-start case-sensitive?))
(values #f #f)))])
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)])))))))

2
gui-lib/framework/private/sig.rkt
View File

@ -182,7 +182,6 @@
(define-signature text-class^
(basic<%>
line-spacing<%>
ascii-art-enlarge-boxes<%>
first-line<%>
line-numbers<%>
foreground-color<%>
@ -226,7 +225,6 @@
basic-mixin
line-spacing-mixin
ascii-art-enlarge-boxes-mixin
first-line-mixin
line-numbers-mixin
foreground-color-mixin

340
gui-lib/framework/private/text.rkt
View File

@ -16,7 +16,6 @@
racket/list
"logging-timer.rkt"
"coroutine.rkt"
"unicode-ascii-art.rkt"
data/queue
racket/unit)
@ -871,89 +870,6 @@
(super-new)))
(define ascii-art-enlarge-boxes<%> text:ascii-art-enlarge-boxes<%>)
(define ascii-art-enlarge-boxes-mixin
(mixin ((class->interface text%)) (ascii-art-enlarge-boxes<%>)
(inherit get-overwrite-mode set-overwrite-mode
get-start-position get-end-position set-position last-position
get-character
begin-edit-sequence end-edit-sequence
position-paragraph paragraph-start-position)
(define ascii-art-enlarge? (preferences:get 'framework:ascii-art-enlarge))
(define/public (get-ascii-art-enlarge) ascii-art-enlarge?)
(define/public (set-ascii-art-enlarge _e?)
(define e? (and _e? #t))
(preferences:set 'framework:ascii-art-enlarge e?)
(set! ascii-art-enlarge? e?))
(define/override (on-default-char c)
(define kc (send c get-key-code))
(define overwrite? (get-overwrite-mode))
(cond
[(not ascii-art-enlarge?) (super on-default-char c)]
[(or (and (char? kc)
(not (member kc '(#\return #\tab #\backspace #\rubout))))
(member (send c get-key-code)
going-to-insert-something))
(begin-edit-sequence)
(define pos (get-start-position))
(define widen? (and (= pos (get-end-position))
(or (not overwrite?)
(insertion-point-at-double-barred-char?))))
(when widen?
(define para (position-paragraph pos))
(define delta-from-start (- pos (paragraph-start-position para)))
(widen-unicode-ascii-art-box this pos)
(define new-pos (+ (paragraph-start-position para) delta-from-start))
(set-position new-pos new-pos))
(unless overwrite? (set-overwrite-mode #t))
(super on-default-char c)
(unless overwrite? (set-overwrite-mode #f))
(end-edit-sequence)]
[else
(super on-default-char c)]))
(define/override (on-local-char c)
(define kc (send c get-key-code))
(define overwrite? (get-overwrite-mode))
(cond
[(not ascii-art-enlarge?) (super on-local-char c)]
[(member kc '(numpad-enter #\return))
(define pos (get-start-position))
(cond
[(= pos (get-end-position))
(heighten-unicode-ascii-art-box this pos)
(define pos-para (position-paragraph pos))
(define pos-para-start (paragraph-start-position pos-para))
(define next-para-start (paragraph-start-position (+ pos-para 1)))
(define just-below-pos (+ next-para-start (- pos pos-para-start)))
(define new-pos
(let loop ([pos just-below-pos])
(cond
[(<= pos next-para-start)
pos]
[(equal? (get-character (- pos 1)) #\║)
pos]
[else (loop (- pos 1))])))
(set-position new-pos new-pos)]
[else
(super on-local-char c)])]
[else
(super on-local-char c)]))
(define/private (insertion-point-at-double-barred-char?)
(define sp (get-start-position))
(and (< sp (last-position))
(equal? (get-character sp) #\║)))
(super-new)))
(define going-to-insert-something
'(multiply
add subtract decimal divide
numpad0 numpad1 numpad2 numpad3 numpad4 numpad5 numpad6 numpad7 numpad8 numpad9))
(define foreground-color<%>
(interface (basic<%> editor:standard-style-list<%>)
@ -1222,7 +1138,7 @@
get-start-position get-end-position
unhighlight-ranges/key unhighlight-range highlight-range
run-after-edit-sequence begin-edit-sequence end-edit-sequence
find-string find-string-embedded get-admin position-line
find-string get-admin position-line
in-edit-sequence? get-pos/text-dc-location
get-canvas get-top-level-window)
@ -1263,7 +1179,7 @@
(car to-replace-highlight)))
;; NEW METHOD: used for test suites
(define/public (search-updates-pending?)
(define/public (search-updates-pending?)
(or update-replace-bubble-callback-running?
search-position-callback-running?
search-coroutine))
@ -1352,16 +1268,16 @@
(when to-replace-highlight
(unhighlight-replace))]
[else
(define next (do-search (get-start-position)))
(define next (do-search (get-start-position) 'eof))
(begin-edit-sequence #t #f)
(cond
[(number? next)
[next
(unless (and to-replace-highlight
(= (car to-replace-highlight) next)
(= (cdr to-replace-highlight)
(string-length searching-str)))
(+ next (string-length searching-str))))
(replace-highlight->normal-hit)
(define pr (cons next (string-length searching-str)))
(define pr (cons next (+ next (string-length searching-str))))
(unhighlight-hit pr)
(highlight-replace pr))]
[else
@ -1378,27 +1294,16 @@
(queue-callback
(λ ()
(when searching-str
(define start-pos (get-focus-editor-start-position))
(define count
(for/sum ([(k v) (in-hash search-bubble-table)])
(define n (if (search-result-compare <= (car k) start-pos) 1 0))
n))
(define count 0)
(define start-pos (get-start-position))
(hash-for-each
search-bubble-table
(λ (k v)
(when (<= (car k) start-pos)
(set! count (+ count 1)))))
(update-before-caret-search-hit-count count))
(set! search-position-callback-running? #f))
#f)))
(define/private (get-focus-editor-start-position)
(let loop ([txt this])
(define focus (send txt get-focus-snip))
(define embedded
(and focus
(is-a? focus editor-snip%)
(is-a? (send focus get-editor) text%)
(send focus get-editor)))
(cond
[embedded
(cons embedded (loop embedded))]
[else (send txt get-start-position)])))
(define/private (update-before-caret-search-hit-count c)
(unless (equal? before-caret-search-hit-count c)
@ -1425,7 +1330,7 @@
(clear-yellow)
(set! clear-yellow void)
(when (and searching-str (= (string-length searching-str) (- end start)))
(when (find-string searching-str 'forward start end #t case-sensitive?)
(when (do-search start end)
(set! clear-yellow (highlight-range
start end
(if (preferences:get 'framework:white-on-black?)
@ -1444,7 +1349,7 @@
(list (list to-replace-highlight 'dark-search-color))
(list))
(hash-map search-bubble-table
(λ (x _true)
(λ (x true)
(list x (if replace-mode? 'light-search-color 'normal-search-color)))))
string<?
#:key (λ (x) (format "~s" (car x)))))
@ -1509,40 +1414,31 @@
[searching-str
(define new-search-bubbles '())
(define new-replace-bubble #f)
(define first-hit (do-search 0))
(define first-hit (do-search 0 'eof))
(define-values (this-search-hit-count this-before-caret-search-hit-count)
(cond
[first-hit
(define sp (get-focus-editor-start-position))
(define sp (get-start-position))
(let loop ([bubble-start first-hit]
[search-hit-count 0]
[before-caret-search-hit-count (if (search-result-compare < first-hit sp) 1 0)])
[before-caret-search-hit-count 1])
(maybe-pause)
(define bubble-end (search-result+ bubble-start (string-length searching-str)))
(define bubble (cons bubble-start (string-length searching-str)))
(define bubble-end (+ bubble-start (string-length searching-str)))
(define bubble (cons bubble-start bubble-end))
(define this-bubble
(cond
[(and replace-mode?
(not new-replace-bubble)
(search-result-compare <= sp bubble-start))
(<= sp bubble-start))
(set! new-replace-bubble bubble)
'the-replace-bubble]
[else
bubble]))
(set! new-search-bubbles (cons this-bubble new-search-bubbles))
(define next (do-search bubble-end))
(when (> (let loop ([x bubble-start])
(cond
[(number? x) 1]
[else (+ 1 (loop (cdr x)))]))
3)
(car))
(define next (do-search bubble-end 'eof))
(define next-before-caret-search-hit-count
(if (and next (search-result-compare < next sp))
(if (and next (< next sp))
(+ 1 before-caret-search-hit-count)
before-caret-search-hit-count))
(cond
@ -1592,82 +1488,15 @@
(send w search-hits-changed)]
[(is-a? w area<%>)
(loop (send w get-parent))]))))))
(define/private (search-result+ search-result num)
(let loop ([search-result search-result])
(cond
[(number? search-result) (+ search-result num)]
[(cons? search-result)
(cons (car search-result)
(loop (cdr search-result)))])))
(define/private (search-result-compare lt l r)
(let loop ([txt this]
[l l]
[r r])
(define (get-the-position x)
;; the zeros shouldn't happen because the editors should still
;; be in the main text object while we are doing stuff with them
(define admin (send x get-admin))
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(or (send txt get-snip-position (send admin get-snip)) 0)]
[else
0]))
(cond
[(and (number? l) (number? r)) (lt l r)]
[(or (number? l) (number? r))
(define ln (if (number? l) l (get-the-position (car l))))
(define rn (if (number? r) r (get-the-position (car r))))
(lt ln rn)]
[else
(cond
[(equal? (car l) (car r))
(loop (car l) (cdr l) (cdr r))]
[else
(lt (get-the-position (car l))
(get-the-position (car r)))])])))
(define all-txt-with-regions-to-clear (make-hasheq))
(define/private (clear-all-regions)
(when to-replace-highlight
(unhighlight-replace))
(for ([(txt _) (in-hash all-txt-with-regions-to-clear)])
(send txt unhighlight-ranges/key 'plt:framework:search-bubbles))
(set! all-txt-with-regions-to-clear (make-hasheq))
(unhighlight-ranges/key 'plt:framework:search-bubbles)
(set! search-bubble-table (make-hash)))
(define/private (do-search start)
(define context (list this))
(define position
(let loop ([start start])
(cond
[(number? start) start]
[else
(set! context (cons (car start) context))
(loop (cdr start))])))
(let loop ([position position]
[context context])
(define found-at-this-level
(send (car context) find-string-embedded searching-str 'forward position 'eof #t case-sensitive?))
(cond
[found-at-this-level
(let loop ([context context])
(cond
[(null? (cdr context)) found-at-this-level]
[else (cons (car context)
(loop (cdr context)))]))]
[(null? (cdr context)) #f]
[else
(define admin (send (car context) get-admin))
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(define snip (send admin get-snip))
(loop (+ (send (second context) get-snip-position snip)
(send snip get-count))
(cdr context))]
[else
(error 'framework/private/text.rkt::searching "admin went wrong ~s" admin)])])))
(define/private (do-search start end)
(find-string searching-str 'forward start end #t case-sensitive?))
;; INVARIANT: when a search bubble is highlighted,
;; the search-bubble-table has it mapped to #t
@ -1677,61 +1506,40 @@
;; this method may be called with bogus inputs (ie a pair that has no highlight)
;; but only when there is a pending "erase all highlights and recompute everything" callback
(define/private (unhighlight-hit bubble)
(hash-remove! search-bubble-table bubble)
(define-values (txt start end) (get-highlighting-text-and-range bubble))
(when txt
(send txt unhighlight-range
start end
(if replace-mode? light-search-color normal-search-color)
#f
'hollow-ellipse)))
(define/private (highlight-hit bubble)
(hash-set! search-bubble-table bubble #t)
(define-values (txt start end) (get-highlighting-text-and-range bubble))
(when txt
(hash-set! all-txt-with-regions-to-clear txt #t)
(send txt highlight-range
start end
(if replace-mode? light-search-color normal-search-color)
#f
'low
'hollow-ellipse
#:key 'plt:framework:search-bubbles
#:adjust-on-insert/delete? #t)))
(define/private (unhighlight-hit pair)
(hash-remove! search-bubble-table pair)
(unhighlight-range (car pair) (cdr pair)
(if replace-mode? light-search-color normal-search-color)
#f
'hollow-ellipse))
(define/private (highlight-hit pair)
(hash-set! search-bubble-table pair #t)
(highlight-range (car pair) (cdr pair)
(if replace-mode? light-search-color normal-search-color)
#f
'low
'hollow-ellipse
#:key 'plt:framework:search-bubbles
#:adjust-on-insert/delete? #t))
;; INVARIANT: the "next to replace" highlight is always
;; saved in 'to-replace-highlight'
(define/private (unhighlight-replace)
(define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight))
(when txt
(send txt unhighlight-range
start end
dark-search-color
#f
'hollow-ellipse))
(unhighlight-range (car to-replace-highlight)
(cdr to-replace-highlight)
dark-search-color
#f
'hollow-ellipse)
(set! to-replace-highlight #f))
(define/private (highlight-replace new-to-replace)
(set! to-replace-highlight new-to-replace)
(define-values (txt start end) (get-highlighting-text-and-range new-to-replace))
(when txt
(send txt highlight-range
start end
dark-search-color
#f
'high
'hollow-ellipse)))
(define/private (get-highlighting-text-and-range bubble)
(let loop ([txt this]
[txt/pr (car bubble)])
(cond
[(number? txt/pr)
(if (is-a? txt text:basic<%>)
(values txt txt/pr (+ txt/pr (cdr bubble)))
(values #f #f #f))]
[else (loop (car txt/pr) (cdr txt/pr))])))
(highlight-range (car to-replace-highlight)
(cdr to-replace-highlight)
dark-search-color
#f
'high
'hollow-ellipse))
(define/private (unhighlight-anchor)
(unhighlight-range anchor-pos anchor-pos "red" #f 'dot)
@ -2471,21 +2279,19 @@
(send base get-bytes))]
[else
(snip-special snip #f #f)]))
;; -> (or/c (is-a?/c snip%) exn:fail?)
(define (snip-special->snip snip-special)
(define the-name (snip-special-name snip-special))
(define snipclass (and the-name (send (get-the-snip-class-list) find the-name)))
(cond
[snipclass
(with-handlers ([exn:fail? values])
(define base (make-object editor-stream-in-bytes-base%
(snip-special-bytes snip-special)))
(define es (make-object editor-stream-in% base))
(read-editor-global-header es)
(define the-snip (send snipclass read es))
(read-editor-global-footer es)
(or the-snip
(snip-special-snip snip-special)))]
(define base (make-object editor-stream-in-bytes-base%
(snip-special-bytes snip-special)))
(define es (make-object editor-stream-in% base))
(read-editor-global-header es)
(define the-snip (send snipclass read es))
(read-editor-global-footer es)
(or the-snip
(snip-special-snip snip-special))]
[else
(snip-special-snip snip-special)]))
@ -2848,26 +2654,12 @@
[(null? txts) (void)]
[else
(define fst (car txts))
(define-values (str/snp style)
(define str/snp
(cond
[(snip-special? (car fst))
(define the-snip
(snip-special->snip (car fst)))
(if (exn:fail? the-snip)
(values (apply
string-append
"error while rendering snip "
(format "~s" (snip-special-name (car fst)))
":\n"
(exn-message the-snip)
" context:\n"
(for/list ([x (in-list (continuation-mark-set->context
(exn-continuation-marks
the-snip)))])
(format " ~s\n" x)))
(add-standard error-style-name))
(values the-snip (cdr fst)))]
[else (values (car fst) (cdr fst))]))
(snip-special->snip (car fst))]
[else (car fst)]))
(define style (cdr fst))
(define inserted-count
(if (is-a? str/snp snip%)

450
gui-lib/framework/private/unicode-ascii-art.rkt
View File

@ -1,450 +0,0 @@
#lang racket/base
(require racket/gui/base
racket/class
racket/contract
2d/dir-chars)
(provide normalize-unicode-ascii-art-box
widen-unicode-ascii-art-box
heighten-unicode-ascii-art-box
center-in-unicode-ascii-art-box)
(define (widen-unicode-ascii-art-box t orig-pos)
(widen/highten-unicode-ascii-art-box t orig-pos #t))
(define (heighten-unicode-ascii-art-box t orig-pos)
(widen/highten-unicode-ascii-art-box t orig-pos #f))
(define (widen/highten-unicode-ascii-art-box t orig-pos widen?)
(define start-pos (scan-for-start-pos t orig-pos))
(when start-pos
(send t begin-edit-sequence)
(define-values (start-x start-y) (pos->xy t orig-pos))
(define start-major (if widen? start-x start-y))
(define min-minor #f)
(define max-minor #f)
(trace-unicode-ascii-art-box
t start-pos #f
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
(define minor (if widen? y x))
(define major (if widen? x y))
(when (= major start-major)
(unless min-minor
(set! min-minor minor)
(set! max-minor minor))
(set! min-minor (min minor min-minor))
(set! max-minor (max minor max-minor)))))
(cond
[widen?
(define to-adjust 0)
(for ([minor (in-range max-minor (- min-minor 1) -1)])
(define-values (pos char) (xy->pos t start-major minor))
(when (< pos start-pos)
(set! to-adjust (+ to-adjust 1)))
(send t insert
(cond
[(member char lt-chars) #\═]
[else #\space])
pos pos))
(send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))]
[else
(define-values (min-pos _1) (xy->pos t min-minor start-major))
(define-values (max-pos _2) (xy->pos t max-minor start-major))
(define para (send t position-paragraph max-pos))
(define para-start (send t paragraph-start-position para))
(define para-end (send t paragraph-end-position para))
(send t insert "\n" para-end para-end)
(for ([to-copy-pos (in-range para-start (+ max-pos 1))])
(define to-insert-pos (+ para-end 1 (- to-copy-pos para-start)))
(define char
(cond
[(< to-copy-pos min-pos) " "]
[else
(define above-char (send t get-character to-copy-pos))
(if (and (member above-char dn-chars)
(member above-char double-barred-chars))
"║"
" ")]))
(send t insert char to-insert-pos to-insert-pos))
(void)])
(send t end-edit-sequence)))
(define (normalize-unicode-ascii-art-box t pos)
(define start-pos (scan-for-start-pos t pos))
(when start-pos
(send t begin-edit-sequence)
(trace-unicode-ascii-art-box
t start-pos #f
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
(cond
[(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
[(and i-dn? i-lt? i-rt?) (set-c t pos "╦")]
[(and i-up? i-lt? i-rt?) (set-c t pos "╩")]
[(and i-up? i-dn? i-rt?) (set-c t pos "╠")]
[(and i-up? i-dn? i-lt?) (set-c t pos "╣")]
[(and i-up? i-lt?) (set-c t pos "╝")]
[(and i-up? i-rt?) (set-c t pos "╚")]
[(and i-dn? i-lt?) (set-c t pos "╗")]
[(and i-dn? i-rt?) (set-c t pos "╔")]
[(or i-up? i-dn?) (set-c t pos "║")]
[else (set-c t pos "═")])))
(send t end-edit-sequence)))
(define (center-in-unicode-ascii-art-box txt insertion-pos)
(define (find-something start-pos inc char-p?)
(define-values (x y) (pos->xy txt start-pos))
(let loop ([pos start-pos])
(cond
[(char-p? (send txt get-character pos))
pos]
[else
(define new-pos (inc pos))
(cond
[(<= 0 new-pos (send txt last-position))
(define-values (x2 y2) (pos->xy txt new-pos))
(cond
[(= y2 y)
(loop new-pos)]
[else #f])]
[else #f])])))
(define (adjust-space before-space after-space pos)
(cond
[(< before-space after-space)
(send txt insert (make-string (- after-space before-space) #\space) pos pos)]
[(> before-space after-space)
(send txt delete pos (+ pos (- before-space after-space)))]))
(define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
(define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
(when (and left-bar right-bar (< left-bar right-bar))
(define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
(define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
(when (and left-space-edge right-space-edge)
(define before-left-space-count (- left-space-edge left-bar 1))
(define before-right-space-count (- right-bar right-space-edge 1))
(define tot-space (+ before-left-space-count before-right-space-count))
(define after-left-space-count (floor (/ tot-space 2)))
(define after-right-space-count (ceiling (/ tot-space 2)))
(send txt begin-edit-sequence)
(adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
(adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
(send txt end-edit-sequence))))
(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
(define visited (make-hash))
(let loop ([pos start-pos])
(unless (hash-ref visited pos #f)
(hash-set! visited pos #t)
(define-values (x y) (pos->xy t pos))
(define c (send t get-character pos))
(define-values (up upc) (xy->pos t x (- y 1)))
(define-values (dn dnc) (xy->pos t x (+ y 1)))
(define-values (lt ltc) (xy->pos t (- x 1) y))
(define-values (rt rtc) (xy->pos t (+ x 1) y))
(define (interesting-dir? dir-c dir-chars)
(or (and (not only-double-barred-chars?)
(member dir-c adjustable-chars)
(member c dir-chars))
(and (member dir-c double-barred-chars)
(member c double-barred-chars))))
(define i-up? (interesting-dir? upc up-chars))
(define i-dn? (interesting-dir? dnc dn-chars))
(define i-lt? (interesting-dir? ltc lt-chars))
(define i-rt? (interesting-dir? rtc rt-chars))
(f pos x y i-up? i-dn? i-lt? i-rt?)
(when i-up? (loop up))
(when i-dn? (loop dn))
(when i-lt? (loop lt))
(when i-rt? (loop rt)))))
(define (scan-for-start-pos t pos)
(define-values (x y) (pos->xy t pos))
(findf
(λ (p) (adj? t p))
(for*/list ([xadj '(0 -1)]
[yadj '(0 -1 1)])
(define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
d)))
(define (adj? t pos)
(and pos
(member (send t get-character pos)
adjustable-chars)))
(define (set-c t pos s)
(unless (equal? (string-ref s 0) (send t get-character pos))
(send t delete pos (+ pos 1))
(send t insert s pos pos)))
(define (pos->xy text pos)
(define para (send text position-paragraph pos))
(define start (send text paragraph-start-position para))
(values (- pos start) para))
(define (xy->pos text x y)
(cond
[(and (<= 0 x) (<= 0 y (send text last-paragraph)))
(define para-start (send text paragraph-start-position y))
(define para-end (send text paragraph-end-position y))
(define pos (+ para-start x))
(define res-pos
(and (< pos para-end)
;; the newline at the end of the
;; line is not on the line, so use this guard
pos))
(if res-pos
(values res-pos (send text get-character res-pos))
(values #f #f))]
[else (values #f #f)]))
(module+ test
(require rackunit
racket/gui/base)
(define sa string-append)
(define (first-value-xy->pos a b c)
(define-values (d e) (xy->pos a b c))
d)
(let ([t (new text%)])
(send t insert (sa "abc\n"
"d\n"
"ghi\n"))
(check-equal? (first-value-xy->pos t 0 0) 0)
(check-equal? (first-value-xy->pos t 1 0) 1)
(check-equal? (first-value-xy->pos t 0 1) 4)
(check-equal? (first-value-xy->pos t 3 0) #f)
(check-equal? (first-value-xy->pos t 0 3) #f)
(check-equal? (first-value-xy->pos t 1 1) #f)
(check-equal? (first-value-xy->pos t 2 1) #f)
(check-equal? (first-value-xy->pos t 0 2) 6)
(check-equal? (first-value-xy->pos t 1 2) 7)
(check-equal? (first-value-xy->pos t 2 -1) #f)
(check-equal? (first-value-xy->pos t -1 0) #f)
(check-equal? (first-value-xy->pos t 2 2) 8)
(check-equal? (first-value-xy->pos t 2 3) #f))
(let ([t (new text%)])
(send t insert (sa "abc\n"
"d\n"
"ghi"))
(check-equal? (first-value-xy->pos t 2 2) 8)
(check-equal? (first-value-xy->pos t 2 3) #f))
(let ([t (new text%)])
(send t insert (string-append "+-+\n"
"| |\n"
"+-+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
"║ ║\n"
"╚═╝\n")))
(let ([t (new text%)])
(send t insert (string-append "+=+\n"
"| |\n"
"+=+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
"║ ║\n"
"╚═╝\n")))
(let ([t (new text%)])
(send t insert (string-append "+-+-+\n"
"| | |\n"
"+-+-+\n"
"| | |\n"
"+-+-+\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═══╗\n"
"║ - ║\n"
"╚═══╝\n"))
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═══╗\n"
"║ - ║\n"
"╚═══╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 1 1)
(widen-unicode-ascii-art-box t 1)
(check-equal? (send t get-start-position) 2)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 8 8)
(widen-unicode-ascii-art-box t 8)
(check-equal? (send t get-start-position) 10)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"))
(send t set-position 8 8)
(widen-unicode-ascii-art-box t 8)
(check-equal? (send t get-text)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n")))
(let ([t (new text%)])
(send t insert (string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 8 8)
(heighten-unicode-ascii-art-box t 8)
(check-equal? (send t get-start-position) 8)
(check-equal? (send t get-text)
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"1 ╔═╦═╗\n"
"2 ║ ║ ║\n"
"3 ╠═╬═╣\n"
"4 ║ ║ ║\n"
"5 ╚═╩═╝\n"))
(send t set-position 11 11)
(heighten-unicode-ascii-art-box t 11)
(check-equal? (send t get-text)
(string-append
"1 ╔═╦═╗\n"
"2 ║ ║ ║\n"
" ║ ║ ║\n"
"3 ╠═╬═╣\n"
"4 ║ ║ ║\n"
"5 ╚═╩═╝\n")))
(let ([t (new text%)])
(send t insert (string-append
"1 ╔═╦═╗\n"
"2 ║ ║ ║\n"
"3 ╠═╬═╣\n"
"4 ║ ║ ║\n"
"5 ╚═╩═╝\n"))
(send t set-position 19 19)
(heighten-unicode-ascii-art-box t 19)
(check-equal? (send t get-text)
(string-append
"1 ╔═╦═╗\n"
"2 ║ ║ ║\n"
"3 ╠═╬═╣\n"
" ║ ║ ║\n"
"4 ║ ║ ║\n"
"5 ╚═╩═╝\n")))
(let ([t (new text%)])
(send t insert "║ x ║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║x ║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║ x║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║ x ║\n"))
(let ([t (new text%)])
(send t insert "║abcde║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║abcde║\n"))
(let ([t (new text%)])
(send t insert "║║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║║\n"))
(let ([t (new text%)])
(send t insert "║abcde \n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
"║abcde \n"))
(let ([t (new text%)])
(send t insert " abcde║\n")
(center-in-unicode-ascii-art-box t 1)
(check-equal? (send t get-text)
" abcde║\n")))
#;
(module+ main
(require framework)
(define f (new frame% [label ""] [width 500] [height 500]))
(define t (new (ascii-art-enlarge-boxes-mixin racket:text%)))
(send t set-overwrite-mode #t)
(define ec (new editor-canvas% [parent f] [editor t]))
(send t insert
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(send t set-position 14 14)
(send f show #t))

2
gui-lib/info.rkt
View File

@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby))
(define version "1.28")
(define version "1.26")

2
gui-lib/mred/private/wxme/keymap.rkt
View File

@ -284,7 +284,7 @@
(if (caps . < . 0) "~l:" "")
(if (altgr . > . 0) "g:" "")
(if (altgr . < . 0) "~g:" "")
(or (hash-ref rev-keylist code #f)
(or (hash-ref rev-keylist code)
(format "~c" code)))])
(error (method-name 'keymap% 'map-function)
"~s is already mapped as a ~aprefix key"

3
gui-lib/mrlib/syntax-browser.rkt
View File

@ -11,7 +11,6 @@ needed to really make this work:
racket/class
racket/gui/base
racket/match
(prefix-in - racket/base)
"include-bitmap.rkt")
(define orig-output-port (current-output-port))
@ -47,7 +46,7 @@ needed to really make this work:
(class snip-class%
(define/override (read stream)
(make-object syntax-snip%
(unmarshall-syntax (-read (open-input-bytes (send stream get-bytes))))))
(unmarshall-syntax (read (open-input-string (send stream get-bytes))))))
(super-new)))
(define snip-class (new syntax-snipclass%))

7
gui-lib/racket/gui/interactive.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require racket/gui/base)
(let ([init-file (cleanse-path (find-graphical-system-path 'init-file))])
(when (file-exists? init-file)
(load init-file)))

20
gui-test/framework/tests/keys.rkt
View File

@ -89,26 +89,6 @@
(sort (hash-map (send k get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
(test
'keymap:aug-keymap%/longer-name
(lambda (x)
(equal? x '((|c:x;r| "swap if branches"))))
(lambda ()
(queue-sexp-to-mred
'(let ()
(define k0 (new keymap:aug-keymap%))
(define k1 (new keymap:aug-keymap%))
(define k2 (new keymap:aug-keymap%))
(send k1 add-function "rectangle" void)
(send k1 map-function "c:x;r;a" "rectangle")
(send k2 add-function "swap if branches" void)
(send k2 map-function "c:x;r" "swap if branches")
(send k0 chain-to-keymap k1 #t)
(send k0 chain-to-keymap k2 #t)
(sort (hash-map (send k0 get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
(define (test-canonicalize name str1 str2)
(test

24
gui-test/framework/tests/search.rkt
View File

@ -67,35 +67,35 @@
(send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 3) normal-search-color)
((4 . 3) normal-search-color)))
((4 . 7) normal-search-color)))
(test-search (list '(begin (send t insert "aba aba")
(send t set-searching-state "aba" #t #f))
'(send t set-position 0 0))
`(((0 . 3) normal-search-color)
((4 . 3) normal-search-color)))
((4 . 7) normal-search-color)))
(test-search (list '(begin (send t insert "abaaba")
(send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 3) normal-search-color)
((3 . 3) normal-search-color)))
((3 . 6) normal-search-color)))
(test-search (list '(begin (send t insert "abaaba")
(send t set-searching-state "aba" #t #f))
'(send t set-position 0 0))
`(((0 . 3) normal-search-color)
((3 . 3) normal-search-color)))
((3 . 6) normal-search-color)))
(test-search (list '(begin (send t insert "abababa")
(send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 3) normal-search-color)
((4 . 3) normal-search-color)))
((4 . 7) normal-search-color)))
(test-search (list '(begin (send t insert "abababa")
(send t set-searching-state "aba" #t #f))
'(send t set-position 0 0))
`(((0 . 3) normal-search-color)
((4 . 3) normal-search-color)))
((4 . 7) normal-search-color)))
(test-search (list '(begin (send t insert "Aba")
(send t set-searching-state "aba" #t #f)
@ -131,25 +131,25 @@
(send t set-searching-state "aba" #f #t)
(send t set-position 0 0)))
`(((0 . 3) dark-search-color)
((4 . 3) light-search-color)))
((4 . 7) light-search-color)))
(test-search (list '(begin (send t insert "abababa")
(send t set-searching-state "aba" #f #t))
'(send t set-position 0 0))
`(((0 . 3) dark-search-color)
((4 . 3) light-search-color)))
((4 . 7) light-search-color)))
(test-search (list '(begin (send t insert "aba aba aba")
(send t set-searching-state "aba" #f #t)
(send t set-position 1 1)))
`(((0 . 3) light-search-color)
((4 . 3) dark-search-color)
((8 . 3) light-search-color)))
((4 . 7) dark-search-color)
((8 . 11) light-search-color)))
(test-search (list '(begin (send t insert "aba aba aba")
(send t set-searching-state "aba" #f #t))
'(send t set-position 1 1))
`(((0 . 3) light-search-color)
((4 . 3) dark-search-color)
((8 . 3) light-search-color)))
((4 . 7) dark-search-color)
((8 . 11) light-search-color)))
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #f #t))

18
gui-test/framework/tests/test-suite-utils.rkt
View File

@ -14,7 +14,7 @@
load-framework-automatically
shutdown-listener shutdown-mred mred-running?
send-sexp-to-mred send-sexp-to-mred/separate-thread queue-sexp-to-mred
send-sexp-to-mred queue-sexp-to-mred
test
wait-for-frame
@ -52,7 +52,7 @@
(module local-namespace racket/base
(require racket/gui/base)
(provide send-sexp-to-mred send-sexp-to-mred/separate-thread
(provide send-sexp-to-mred
queue-sexp-to-mred
eof-result?
shutdown-listener shutdown-mred mred-running?
@ -76,13 +76,6 @@
(eval sexp)))))
(channel-get c))
(define (send-sexp-to-mred/separate-thread sexp)
(unless ns?
(namespace-require 'framework)
(namespace-require 'racket/gui/base)
(set! ns? #t))
(eval sexp))
(define queue-sexp-to-mred send-sexp-to-mred)
(define (eof-result? x)
@ -127,7 +120,7 @@
"debug.rkt"
racket/tcp
racket/pretty)
(provide send-sexp-to-mred send-sexp-to-mred/separate-thread
(provide send-sexp-to-mred
queue-sexp-to-mred
eof-result?
shutdown-listener shutdown-mred mred-running?
@ -279,9 +272,6 @@
[(normal)
(eval (list-ref answer 1))]))))))
(define (send-sexp-to-mred/separate-thread sexp)
(send-sexp-to-mred sexp))
(define queue-sexp-to-mred
(lambda (sexp)
(send-sexp-to-mred
@ -329,7 +319,7 @@
(define n (if use-local? l:n r:n))
(choose ns ...))))]))
(choose send-sexp-to-mred send-sexp-to-mred/separate-thread
(choose send-sexp-to-mred
queue-sexp-to-mred
eof-result?
shutdown-listener shutdown-mred mred-running?

173
gui-test/framework/tests/text.rkt
View File

@ -355,98 +355,6 @@
(send t insert (new snip%) (send t last-position))
(send t all-string-snips?)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; searching
;;
(define (search-test name setup-code expected-answer)
(test
name
(λ (x) (equal? x expected-answer))
(λ ()
(send-sexp-to-mred/separate-thread
`(let ()
(define answer (make-channel))
(queue-callback
(λ ()
(define t (new text:searching%))
,setup-code
(let loop ()
(cond
[(send t search-updates-pending?)
(queue-callback (λ () (loop)) #f)]
[else
(define-values (before total) (send t get-search-hit-count))
(channel-put answer (list before total))]))))
(channel-get answer))))))
(search-test
'search.1
`(begin (send t insert "abc")
(send t set-position 0 0)
(send t set-searching-state "b" #f #f))
(list 0 1))
(search-test
'search.2
`(begin (send t insert "abc")
(send t set-position 3 3)
(send t set-searching-state "b" #f #f))
(list 1 1))
(search-test
'search.3
`(begin (send t insert "abc")
(define t2 (new text%))
(send t2 insert "abc")
(send t insert (new editor-snip% [editor t2]))
(send t2 insert "abc")
(send t set-position 0 0)
(send t set-searching-state "b" #f #f))
(list 0 3))
(search-test
'search.4
`(begin (send t insert "abc")
(define t2 (new text%))
(send t2 insert "abc")
(send t insert (new editor-snip% [editor t2]))
(send t insert "abc")
(send t set-position (send t last-position) (send t last-position))
(send t set-searching-state "b" #f #f))
(list 3 3))
(search-test
'search.5
`(begin (send t insert "abc")
(define t2 (new text%))
(send t2 insert "abc")
(define t3 (new text%))
(send t3 insert "abc")
(send t2 insert (new editor-snip% [editor t3]))
(send t2 insert "abc")
(send t insert (new editor-snip% [editor t2]))
(send t insert "abc")
(send t set-position (send t last-position) (send t last-position))
(send t set-searching-state "b" #f #f))
(list 5 5))
(search-test
'search.6
`(begin (send t insert "abc")
(define t2 (new text%))
(send t2 insert "abc")
(define t3 (new text%))
(send t3 insert "abc")
(send t2 insert (new editor-snip% [editor t3]))
(send t2 insert "abc")
(send t insert (new editor-snip% [editor t2]))
(send t insert "abc")
(send t set-position 0 0)
(send t set-searching-state "b" #f #f))
(list 0 5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; print-to-dc
@ -754,84 +662,3 @@
(loop)))
(define after (get-colors))
(list before after)))))
(define (test-ascii-art-enlarge-boxes-mixin name before position overwrite? chars after)
(test
name
(λ (got) (equal? got after))
(λ ()
(queue-sexp-to-mred
`(let ([t (new (text:ascii-art-enlarge-boxes-mixin text%))])
(send t set-ascii-art-enlarge #t)
(define f (new frame% [label ""]))
(define ec (new editor-canvas% [parent f] [editor t]))
(send t insert
,before)
(send t set-position ,position ,position)
,@(if overwrite? (list '(send t set-overwrite-mode #t)) '())
,@(for/list ([char (in-list chars)])
`(send ec on-char (new key-event% [key-code ,char])))
(send t get-text))))))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.1
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")
7 #t '(#\a)
(string-append
"╔═╦═╗\n"
"║a║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.2
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")
7 #t'(#\a #\b)
(string-append
"╔══╦═╗\n"
"║ab║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.3
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")
7 #f '(#\a)
(string-append
"╔══╦═╗\n"
"║a ║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.4
(string-append
"╔═╦═╗\n"
"║ ║ ║\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n")
14 #f '(#\f)
(string-append
"╔══╦═╗\n"
"║ ║ ║\n"
"║ f║ ║\n"
"╠══╬═╣\n"
"║ ║ ║\n"
"╚══╩═╝\n"))

15
gui-test/mrlib/tests/syntax-browser.rkt
View File

@ -1,15 +0,0 @@
#lang racket/gui
(require mrlib/syntax-browser rackunit)
(let ()
(struct m ([x #:mutable]))
(define v (m 0))
(define stx (datum->syntax #'here v))
(set-m-x! v stx)
(define t (new text%))
(send t insert (render-syntax/snip stx))
(define bp (open-output-bytes))
(send t save-port bp)
(define t2 (new text%))
(send t2 insert-port (open-input-bytes (get-output-bytes bp)))
(check-regexp-match #rx"syntax-snip" (~s (send t2 find-first-snip))))

10
gui-test/tests/gracket/wxme.rkt
View File

@ -1212,16 +1212,6 @@
(expect (send km handle-key-event 'obj kevt) #t)
(expect hit #\t)
(let ()
(define k (new keymap%))
(send k add-function "swap if branches" void)
(send k map-function "c:x;r" "swap if branches")
(send k add-function "rectangle" void)
(expect (regexp-match? (regexp-quote "map-function in keymap%: \"r\" is already mapped as a non-prefix key")
(with-handlers ([exn:fail? exn-message])
(send k map-function "c:x;r;a" "rectangle")))
#t))
;; Chained keymap non-prefixed overrides prefixed
(send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d)))
(send km2 map-function "d" "letter-d")