add syntax coloring for 2d syntax
original commit: 30ca1f0baf57957bad9be093785a4dae2e318199
This commit is contained in:
Robby Findler
parent
b5194ef617
commit
06ca5775a5
|
|
@ -41,4 +41,4 @@
|
|||
|
||||
(define double-barred-chars
|
||||
(remove* '(#\+ #\- #\= #\|)
|
||||
adjustable-chars))
|
||||
adjustable-chars))
|
||||
|
|
|
|||
|
|
@ -31,7 +31,9 @@
|
|||
(lambda (proc)
|
||||
(lambda (key defval)
|
||||
(case key
|
||||
#;
|
||||
[(color-lexer)
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
|
||||
(define theirs
|
||||
(or (and proc (proc key #f))
|
||||
(dynamic-require 'syntax-color/racket-lexer 'racket-lexer)))
|
||||
((dynamic-require 'unstable/2d/lexer 'lexer) theirs)]
|
||||
[else (if proc (proc key defval) defval)])))))
|
||||
|
|
|
|||
3
collects/unstable/2d/lexer.rkt
Normal file
3
collects/unstable/2d/lexer.rkt
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(require "private/lexer.rkt")
|
||||
(provide lexer)
|
||||
373
collects/unstable/2d/private/lexer.rkt
Normal file
373
collects/unstable/2d/private/lexer.rkt
Normal file
|
|
@ -0,0 +1,373 @@
|
|||
#lang racket/base
|
||||
(require "read-util.rkt"
|
||||
"../dir-chars.rkt"
|
||||
racket/set
|
||||
racket/port)
|
||||
|
||||
#|
|
||||
|
||||
todo:
|
||||
- backup delta
|
||||
- errors
|
||||
- do I need absolute positions? (start & end)? yes, for filling gaps.
|
||||
- break up the table into two pieces
|
||||
... build test suite
|
||||
|
||||
|
||||
|#
|
||||
|
||||
(provide lexer
|
||||
cropped-regions)
|
||||
|
||||
(define (lexer chained-lexer)
|
||||
(define uniform-chained-lexer
|
||||
(cond
|
||||
[(procedure-arity-includes? chained-lexer 3)
|
||||
chained-lexer]
|
||||
[else
|
||||
(λ (port offset mode)
|
||||
(define-values (val tok paren start end) (chained-lexer port))
|
||||
(values val tok paren start end 0 #f))]))
|
||||
(define (2dcond-lexer port offset _mode)
|
||||
(define a-2d-lexer-state (or _mode (2d-lexer-state '() #f #f)))
|
||||
(cond
|
||||
[(pair? (2d-lexer-state-pending-tokens a-2d-lexer-state))
|
||||
(define-values (line col pos) (port-next-location port))
|
||||
(define-values (val tok paren start end)
|
||||
(apply values (car (2d-lexer-state-pending-tokens a-2d-lexer-state))))
|
||||
|
||||
;; read the characters in (expecting the same string as in 'val')
|
||||
(for ([c1 (in-string val)]
|
||||
[i (in-naturals)])
|
||||
(define c2 (read-char port))
|
||||
(unless (or
|
||||
;; don't check these, as they are not always
|
||||
;; right (the ones outside the table, specifically
|
||||
;; are always just spaces)
|
||||
(eq? tok 'white-space)
|
||||
(equal? c1 c2))
|
||||
(error '2d/lexer.rkt "expected a ~s, got ~s while feeding token ~s" c1 c2
|
||||
(car (2d-lexer-state-pending-tokens a-2d-lexer-state)))))
|
||||
|
||||
(values val tok paren
|
||||
pos
|
||||
(+ (- end start) pos)
|
||||
start
|
||||
(struct-copy 2d-lexer-state
|
||||
a-2d-lexer-state
|
||||
[pending-tokens
|
||||
(cdr (2d-lexer-state-pending-tokens
|
||||
a-2d-lexer-state))]))]
|
||||
[(equal? #\# (peek-char port))
|
||||
(define pp (peeking-input-port port))
|
||||
(define chars (list (read-char pp) (read-char pp) (read-char pp)))
|
||||
(cond
|
||||
[(equal? chars '(#\# #\2 #\d))
|
||||
(start-new-2d-cond-lexing port a-2d-lexer-state uniform-chained-lexer offset)]
|
||||
[else
|
||||
(call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state)])]
|
||||
[else
|
||||
(call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state)]))
|
||||
2dcond-lexer)
|
||||
|
||||
|
||||
(define double-barred-chars-regexp
|
||||
(regexp
|
||||
(format "[~a]" (apply string double-barred-chars))))
|
||||
|
||||
(define (call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state)
|
||||
(define-values (a b c d e f new-mode)
|
||||
(uniform-chained-lexer port offset (2d-lexer-state-chained-state a-2d-lexer-state)))
|
||||
(values a b c d e f (2d-lexer-state '() #f new-mode)))
|
||||
|
||||
(struct 2d-lexer-state (pending-tokens read-state chained-state))
|
||||
|
||||
(define (start-new-2d-cond-lexing port a-2d-lexer-state uniform-chained-lexer offset)
|
||||
(define-values (line col pos) (port-next-location port))
|
||||
;; consume #\# #\2 and #\d that must be there (peeked them earlier)
|
||||
(read-char port)
|
||||
(read-char port)
|
||||
(read-char port)
|
||||
;; read in the keyword and get those tokens
|
||||
|
||||
(define-values (backwards-chars eol-string)
|
||||
(let loop ([kwd-chars '(#\d #\2 #\#)])
|
||||
(define c (peek-char port))
|
||||
(cond [(eof-object? c) (values kwd-chars "")]
|
||||
[(and (equal? c #\return)
|
||||
(equal? (peek-char port 1) #\newline))
|
||||
(values kwd-chars (string c #\newline))]
|
||||
[(or (equal? c #\return)
|
||||
(equal? c #\newline))
|
||||
(values kwd-chars (string c))]
|
||||
[else
|
||||
(read-char port) ;; actually get the char
|
||||
(loop (cons c kwd-chars))])))
|
||||
(define first-tok-string
|
||||
(apply string (reverse backwards-chars)))
|
||||
(cond
|
||||
[(eof-object? (peek-char port))
|
||||
(values first-tok-string
|
||||
'error
|
||||
#f
|
||||
pos
|
||||
(+ pos (string-length first-tok-string))
|
||||
0
|
||||
a-2d-lexer-state)]
|
||||
[else
|
||||
(define port->peek-port-delta
|
||||
(let-values ([(_1 _2 c-pos) (port-next-location port)])
|
||||
c-pos))
|
||||
(define base-position
|
||||
;; one might think that this should depend on the length of eol-string
|
||||
;; but ports that have port-count-lines! enabled count the \r\n combination
|
||||
;; as a single position in the port, not 2.
|
||||
(+ pos port->peek-port-delta -1))
|
||||
(define peek-port (peeking-input-port port))
|
||||
;; pull the newline out of the peek-port
|
||||
(for ([x (in-range (string-length eol-string))]) (read-char peek-port))
|
||||
|
||||
(define the-state (make-state line pos (string-length first-tok-string)))
|
||||
(setup-state the-state)
|
||||
|
||||
;; would like to be able to stop this loop
|
||||
;; and process only part of the table,
|
||||
;; but that works only when there are no broken
|
||||
;; edges of the table that span the place I want to stop.
|
||||
(define failed
|
||||
(with-handlers ((exn:fail:read?
|
||||
(λ (exn) exn)))
|
||||
(let loop ([map #f])
|
||||
(define new-map
|
||||
;; this might raise a read exception: what then?
|
||||
(parse-2dcond-one-step peek-port (object-name peek-port) #f #f pos the-state map))
|
||||
(when new-map
|
||||
(loop new-map)))))
|
||||
|
||||
(define newline-token
|
||||
(list eol-string 'white-space #f
|
||||
(+ pos (string-length first-tok-string))
|
||||
;; no matter how long eol-string is, it counts for 1 position only.
|
||||
(+ pos (string-length first-tok-string) 1)))
|
||||
|
||||
(define final-tokens
|
||||
(cond
|
||||
[(exn:fail:read? failed)
|
||||
(define error-pos (- (srcloc-position (car (exn:fail:read-srclocs failed)))
|
||||
port->peek-port-delta)) ;; account for the newline
|
||||
(define peek-port2 (peeking-input-port port))
|
||||
(port-count-lines! peek-port2)
|
||||
|
||||
;; pull the newline out of peek-port2
|
||||
(for ([x (in-range (string-length eol-string))]) (read-char peek-port2))
|
||||
|
||||
(define (pull-chars n)
|
||||
(apply
|
||||
string
|
||||
(let loop ([n n])
|
||||
(cond
|
||||
[(zero? n) '()]
|
||||
[else (cons (read-char peek-port2) (loop (- n 1)))]))))
|
||||
(define before-token (list (pull-chars error-pos)
|
||||
'no-color
|
||||
#f
|
||||
(+ base-position 1)
|
||||
(+ base-position 1 error-pos)))
|
||||
(define end-of-table-approx
|
||||
(let ([peek-port3 (peeking-input-port peek-port2)])
|
||||
(port-count-lines! peek-port3)
|
||||
(let loop ()
|
||||
(define l (read-line peek-port3))
|
||||
(define-values (line col pos) (port-next-location peek-port3))
|
||||
(cond
|
||||
[(and (string? l)
|
||||
(regexp-match double-barred-chars-regexp l))
|
||||
(loop)]
|
||||
[else pos]))))
|
||||
(define after-token
|
||||
(list (pull-chars (- end-of-table-approx 1))
|
||||
'error
|
||||
#f
|
||||
(+ base-position 1 error-pos)
|
||||
(+ base-position 1 error-pos end-of-table-approx -1)))
|
||||
(list newline-token before-token after-token)]
|
||||
[else
|
||||
|
||||
(define lhses (close-cell-graph cell-connections (length table-column-breaks) (length rows)))
|
||||
(define scratch-string (make-string (for/sum ([ss (in-list rows)])
|
||||
(for/sum ([s (in-list ss)])
|
||||
(string-length s)))
|
||||
#\space))
|
||||
(define collected-tokens '())
|
||||
(define rows-as-vector (apply vector (reverse rows)))
|
||||
(for ([set-of-indicies (in-list (sort (set->list lhses) compare/xy
|
||||
#:key smallest-representative))])
|
||||
(define regions
|
||||
(fill-scratch-string set-of-indicies
|
||||
rows-as-vector
|
||||
scratch-string
|
||||
table-column-breaks
|
||||
initial-space-count
|
||||
#t))
|
||||
(define port (open-input-string scratch-string))
|
||||
(let loop ([mode (2d-lexer-state-chained-state a-2d-lexer-state)])
|
||||
(define-values (_1 _2 current-pos) (port-next-location port))
|
||||
(define-values (str tok paren start end backup new-mode)
|
||||
(uniform-chained-lexer port (+ pos offset) mode))
|
||||
(unless (equal? 'eof tok)
|
||||
(for ([sub-region (in-list (cropped-regions start end regions))])
|
||||
(set! collected-tokens
|
||||
(cons (list (substring str
|
||||
(- (car sub-region) current-pos)
|
||||
(- (cdr sub-region) current-pos))
|
||||
tok
|
||||
paren
|
||||
(+ base-position (car sub-region))
|
||||
(+ base-position (cdr sub-region)))
|
||||
collected-tokens)))
|
||||
(loop new-mode))))
|
||||
|
||||
(define (collect-double-barred-token pending-start i offset str)
|
||||
(when pending-start
|
||||
(set! collected-tokens (cons (list (substring str pending-start i)
|
||||
'parenthesis
|
||||
#f
|
||||
(+ base-position offset pending-start)
|
||||
(+ base-position offset i))
|
||||
collected-tokens))))
|
||||
|
||||
(for/fold ([offset 1]) ([strs (in-list (reverse (cons (list current-line) rows)))])
|
||||
(for/fold ([offset offset]) ([str (in-list strs)])
|
||||
(let loop ([i 0]
|
||||
[pending-start #f])
|
||||
(cond
|
||||
[(< i (string-length str))
|
||||
(define c (string-ref str i))
|
||||
(cond
|
||||
[(member c double-barred-chars)
|
||||
(loop (+ i 1)
|
||||
(if pending-start pending-start i))]
|
||||
[else
|
||||
(collect-double-barred-token pending-start i offset str)
|
||||
(loop (+ i 1) #f)])]
|
||||
[else
|
||||
(collect-double-barred-token pending-start i offset str)]))
|
||||
(+ (string-length str) offset)))
|
||||
|
||||
(define sorted-tokens (sort collected-tokens <
|
||||
#:key (λ (x) (list-ref x 3))))
|
||||
|
||||
;; there will be gaps that correspond to the places outside of the
|
||||
;; outermost rectangle (at a minimum, newlines); this fills those
|
||||
;; in with whitespace tokens
|
||||
(define cracks-filled-in-tokens
|
||||
(let loop ([fst (car sorted-tokens)]
|
||||
[tokens (cdr sorted-tokens)])
|
||||
(cond
|
||||
[(null? tokens) (list fst)]
|
||||
[else
|
||||
(define snd (car tokens))
|
||||
(cond
|
||||
[(= (list-ref fst 4)
|
||||
(list-ref snd 3))
|
||||
(cons fst (loop snd (cdr tokens)))]
|
||||
[else
|
||||
(define new-start (list-ref fst 4))
|
||||
(define new-end (list-ref snd 3))
|
||||
(list* fst
|
||||
(list
|
||||
; these are not the real characters ...
|
||||
(make-string (- new-end new-start) #\space)
|
||||
'white-space
|
||||
#f
|
||||
new-start
|
||||
new-end)
|
||||
(loop snd (cdr tokens)))])])))
|
||||
(cons newline-token cracks-filled-in-tokens)]))
|
||||
|
||||
(values first-tok-string 'hash-colon-keyword #f
|
||||
pos (+ pos (string-length first-tok-string))
|
||||
0
|
||||
(2d-lexer-state final-tokens
|
||||
#t
|
||||
(2d-lexer-state-chained-state a-2d-lexer-state)))]))
|
||||
|
||||
(define (cropped-regions start end regions)
|
||||
(define result-regions '())
|
||||
(define (add start end)
|
||||
(unless (= start end)
|
||||
(set! result-regions (cons (cons start end) result-regions))))
|
||||
(let loop ([regions regions]
|
||||
[start start]
|
||||
[end end])
|
||||
(unless (null? regions)
|
||||
(define region (car regions))
|
||||
(cond
|
||||
[(<= start (car region))
|
||||
(cond
|
||||
[(<= end (car region))
|
||||
(void)]
|
||||
[(<= end (cdr region))
|
||||
(add (car region) end)]
|
||||
[else
|
||||
(add (car region) (cdr region))
|
||||
(loop (cdr regions)
|
||||
(cdr region)
|
||||
end)])]
|
||||
[(<= start (cdr region))
|
||||
(cond
|
||||
[(<= end (cdr region))
|
||||
(add start end)]
|
||||
[else
|
||||
(add start (cdr region))
|
||||
(loop (cdr regions)
|
||||
(cdr region)
|
||||
end)])]
|
||||
[else
|
||||
(loop (cdr regions) start end)])))
|
||||
result-regions)
|
||||
|
||||
|
||||
#|
|
||||
(define scratch-string (make-string (for/sum ([ss (in-vector lines)])
|
||||
(for/sum ([s (in-list ss)])
|
||||
(string-length s)))
|
||||
#\space))
|
||||
|
||||
(define heights
|
||||
(for/list ([line (in-vector lines)])
|
||||
(length line)))
|
||||
|
||||
`(,(string->symbol (string-append "2d" (apply string kwd-chars)))
|
||||
|
||||
,table-column-breaks
|
||||
,heights
|
||||
|
||||
,@(for/list ([set-of-indicies (in-list (sort (set->list lhses) compare/xy
|
||||
#:key smallest-representative))])
|
||||
(fill-scratch-string set-of-indicies
|
||||
lines
|
||||
scratch-string
|
||||
table-column-breaks
|
||||
initial-space-count)
|
||||
(define scratch-port (open-input-string scratch-string))
|
||||
(when post-2d-line (port-count-lines! scratch-port))
|
||||
(set-port-next-location! scratch-port post-2d-line post-2d-col post-2d-span)
|
||||
`[,(sort (set->list set-of-indicies) compare/xy)
|
||||
,@(read-subparts source scratch-port
|
||||
initial-space-count table-column-breaks heights set-of-indicies
|
||||
previous-readtable /recursive)]))
|
||||
|#
|
||||
|
||||
#;
|
||||
(module+ main
|
||||
(define p (open-input-string (string-append
|
||||
"╔══╦══╗\n"
|
||||
"║1 ║2 ║\n"
|
||||
"╠══╬══╣\n"
|
||||
"║4 ║3 ║\n"
|
||||
"╚══╩══╝\n")))
|
||||
(port-count-lines! p)
|
||||
;; account for the "#2d" that was read from the first line
|
||||
(call-with-values (λ () (tokenize-2dcond p "source" 1 0 1 2))
|
||||
list))
|
||||
684
collects/unstable/2d/private/read-util.rkt
Normal file
684
collects/unstable/2d/private/read-util.rkt
Normal file
|
|
@ -0,0 +1,684 @@
|
|||
#lang racket/base
|
||||
#|
|
||||
|
||||
ideas:
|
||||
- 2dcond
|
||||
- 2dmatch
|
||||
- literal tables in scribble layout?
|
||||
- something for 2d graphics?
|
||||
|
||||
example uses:
|
||||
- unifier
|
||||
- subtyping relation
|
||||
- merge (from merge-sort)
|
||||
|
||||
|#
|
||||
|
||||
(require racket/port
|
||||
syntax/readerr
|
||||
racket/match
|
||||
racket/set
|
||||
;syntax/rect
|
||||
"../dir-chars.rkt"
|
||||
(for-syntax racket/base
|
||||
racket/list))
|
||||
|
||||
|
||||
(provide parse-2dcond
|
||||
parse-2dcond-one-step
|
||||
|
||||
setup-state
|
||||
make-state
|
||||
copy-state
|
||||
|
||||
chars->desc
|
||||
smallest-representative
|
||||
all-line-of-interest
|
||||
current-lines
|
||||
close-cell-graph
|
||||
compare/xy
|
||||
fill-scratch-string)
|
||||
|
||||
(define all-line-of-interest (make-hash))
|
||||
(define current-lines (make-parameter #f))
|
||||
(define-syntax (line-of-interest stx)
|
||||
(with-syntax ([line (syntax-line stx)])
|
||||
(syntax-local-lift-expression #'(hash-set! all-line-of-interest line #t))
|
||||
#'(visited line)))
|
||||
(define (visited line)
|
||||
(define t (current-lines))
|
||||
(when t
|
||||
(hash-remove! t line)))
|
||||
|
||||
;; fill-scratch-string : (setof (list/c number? number?))
|
||||
;; (vector (listof string?))
|
||||
;; (or/c string? #f)
|
||||
;; (listof number)
|
||||
;; number
|
||||
;; [boolean?]
|
||||
;; -> (if scratch-string
|
||||
;; (values (listof (cons/c number? number?))
|
||||
;; (listof (cons/c number? number?)))
|
||||
;; void?)
|
||||
;; scratch-string gets filled in from the 'lines' argument.
|
||||
;; If compute-regions? is #t, then this function constructs the regions of the
|
||||
;; string that are have been filled in (as a list of pairs of start/end coordinates)
|
||||
;; and returns that (not counting the regions outside of the table to the right--
|
||||
;; these get filled in to the string, but the regions are not included)
|
||||
;; the resulting regions are sorted (smaller to bigger values) and non-overlapping
|
||||
(define (fill-scratch-string set-of-indicies
|
||||
lines
|
||||
scratch-string
|
||||
table-column-breaks
|
||||
initial-space-count
|
||||
[compute-regions? #f])
|
||||
|
||||
(define scratch-pos 0)
|
||||
|
||||
(define eols '())
|
||||
(define segments '())
|
||||
(define cur-seg-start #f)
|
||||
(define cur-seg-end #f)
|
||||
(define (add-keeper)
|
||||
(cond
|
||||
[(equal? cur-seg-end scratch-pos)
|
||||
(set! cur-seg-end (+ cur-seg-end 1))]
|
||||
[else
|
||||
(record-position)
|
||||
(set! cur-seg-start scratch-pos)
|
||||
(set! cur-seg-end (+ scratch-pos 1))]))
|
||||
(define (record-position)
|
||||
(when (and cur-seg-start cur-seg-end)
|
||||
;; port positions count from 1, but here
|
||||
;; we're counting from 0 in the string, so inc
|
||||
(set! segments (cons (cons (+ cur-seg-start 1)
|
||||
(+ cur-seg-end 1))
|
||||
segments))))
|
||||
|
||||
(define-syntax-rule
|
||||
(set-scratch! in? c)
|
||||
(begin
|
||||
(let ([x c])
|
||||
;(unless (char-whitespace? x) (printf "putting ~s @ ~s\n" x scratch-pos))
|
||||
(string-set! scratch-string scratch-pos x))
|
||||
(when in? (when compute-regions? (add-keeper)))))
|
||||
(define-syntax-rule
|
||||
(clear-scratch!)
|
||||
(when scratch-string (string-set! scratch-string scratch-pos #\space)))
|
||||
(define-syntax-rule
|
||||
(inc-scratch-pos! e)
|
||||
(set! scratch-pos (+ scratch-pos e)))
|
||||
(for ([lines (in-vector lines)]
|
||||
[y (in-naturals)])
|
||||
(for ([line (in-list lines)]
|
||||
[l-num (in-naturals)])
|
||||
(define first-line? (zero? l-num))
|
||||
;; skip over initial spaces: we know that the string is already right here
|
||||
;; because it is initialized with spaces and never changed
|
||||
;; the +1 is for the first character (in the current line)
|
||||
;; of the table, which is always a table edge character
|
||||
(inc-scratch-pos! (+ initial-space-count 1))
|
||||
(define end-of-table-position
|
||||
(for/fold ([start-pos-in-line (+ initial-space-count 1)])
|
||||
([table-column-break (in-list table-column-breaks)]
|
||||
[x (in-naturals)])
|
||||
(cond
|
||||
[(and (set-member? set-of-indicies (list x y))
|
||||
(or (not first-line?)
|
||||
(set-member? set-of-indicies (list x (- y 1)))))
|
||||
(for ([j (in-range table-column-break)])
|
||||
(set-scratch! #t (string-ref line (+ j start-pos-in-line)))
|
||||
(inc-scratch-pos! 1))
|
||||
(if (if first-line?
|
||||
(and (set-member? set-of-indicies (list (+ x 1) (- y 1)))
|
||||
(set-member? set-of-indicies (list (+ x 1) y))
|
||||
(set-member? set-of-indicies (list x (- y 1))))
|
||||
(set-member? set-of-indicies (list (+ x 1) y)))
|
||||
(set-scratch! #t (string-ref line (+ table-column-break start-pos-in-line)))
|
||||
(clear-scratch!))
|
||||
(inc-scratch-pos! 1)]
|
||||
[else
|
||||
(for ([j (in-range table-column-break)])
|
||||
(clear-scratch!)
|
||||
(inc-scratch-pos! 1))
|
||||
(clear-scratch!)
|
||||
(inc-scratch-pos! 1)])
|
||||
(+ start-pos-in-line table-column-break 1)))
|
||||
(set! eols (cons (cons end-of-table-position (string-length line))
|
||||
eols))
|
||||
(for ([j (in-range end-of-table-position (string-length line))])
|
||||
(set-scratch! #f (string-ref line j))
|
||||
(inc-scratch-pos! 1))))
|
||||
|
||||
(when compute-regions?
|
||||
(record-position)
|
||||
(reverse segments)))
|
||||
|
||||
(define (compare/xy p1 p2)
|
||||
(cond
|
||||
[(= (list-ref p1 0) (list-ref p2 0))
|
||||
(< (list-ref p1 1) (list-ref p2 1))]
|
||||
[else
|
||||
(< (list-ref p1 0) (list-ref p2 0))]))
|
||||
|
||||
(define (smallest-representative set)
|
||||
(define lst (set->list set))
|
||||
(let loop ([best (car lst)]
|
||||
[rest (cdr lst)])
|
||||
(cond
|
||||
[(null? rest) best]
|
||||
[else
|
||||
(cond
|
||||
[(compare/xy best (car rest))
|
||||
(loop best (cdr rest))]
|
||||
[else
|
||||
(loop (car rest) (cdr rest))])])))
|
||||
|
||||
(define (close-cell-graph edges width height)
|
||||
(define res (make-hash))
|
||||
(for ([x (in-range width)])
|
||||
(for ([y (in-range height)])
|
||||
(hash-set! res (list x y) (set (list x y)))))
|
||||
|
||||
(let loop ()
|
||||
(define something-changed? #f)
|
||||
(define (add-all n1 n2)
|
||||
(define in-n1 (hash-ref res n1))
|
||||
(define in-n2 (hash-ref res n2))
|
||||
(for ([new-node (in-set in-n1)])
|
||||
(unless (set-member? in-n2 new-node)
|
||||
(set! something-changed? #t)
|
||||
(hash-set! res n2 (set-add in-n2 new-node)))))
|
||||
|
||||
(for ([(node-src nodes) (in-hash edges)])
|
||||
(for ([node-dest (in-set nodes)])
|
||||
(add-all node-dest node-src)
|
||||
(add-all node-src node-dest)))
|
||||
|
||||
(when something-changed? (loop)))
|
||||
|
||||
(apply set (hash-map res (λ (x y) y))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define state-components
|
||||
;; these are the state variables for the parse-2d-cond procedure
|
||||
'((current-line-number _line)
|
||||
(current-line-start-position (+ (or _pos 0) chars-read))
|
||||
(current-line #f)
|
||||
(current-line-length 0)
|
||||
(initial-space-count 0)
|
||||
(initial-column-guide #f)
|
||||
(newline-char-count 0)
|
||||
(table-column-breaks '())
|
||||
(table-column-guides '())
|
||||
(right-edge-column #f)
|
||||
(pending-row '())
|
||||
(rows '())
|
||||
(current-row 0)
|
||||
(cell-connections (make-hash)))))
|
||||
|
||||
(define-syntax (setup-state stx)
|
||||
(syntax-case stx ()
|
||||
[(_ state-struct-id #;state-accessor #;state-mutator)
|
||||
#`(begin
|
||||
#,@(for/list ([state-component (in-list state-components)]
|
||||
[i (in-naturals)])
|
||||
(with-syntax ([id (datum->syntax #'state-struct-id (car state-component))]
|
||||
[i i])
|
||||
#'(define-syntax id
|
||||
(make-set!-transformer
|
||||
(λ (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! x e)
|
||||
#'(state-mutator state-struct-id i e)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'(state-accessor state-struct-id i)])))))))]))
|
||||
|
||||
(define-syntax (state-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ make-state state-accessor state-mutator copy-state)
|
||||
#`(begin
|
||||
(define-values (state-type state-constructor state? state-accessor state-mutator)
|
||||
(make-struct-type 'parse-2d-cond-state #f #,(length state-components) 0 #f '() #f))
|
||||
(define (make-state _line _pos chars-read)
|
||||
(state-constructor #,@(for/list ([state-component (in-list state-components)])
|
||||
(list-ref state-component 1))))
|
||||
(define (copy-state the-state)
|
||||
(state-constructor #,@(for/list ([state-component (in-list state-components)]
|
||||
[i (in-naturals)])
|
||||
#`(state-accessor the-state #,i)))))]))
|
||||
|
||||
(state-struct make-state state-accessor state-mutator copy-state)
|
||||
|
||||
(define (parse-2dcond port source _line _col _pos chars-read)
|
||||
(define the-state (make-state _line _pos chars-read))
|
||||
(let loop ([map #f])
|
||||
(define new-map
|
||||
(parse-2dcond-one-step port source _line _col _pos the-state map))
|
||||
(cond
|
||||
[new-map
|
||||
(loop new-map)]
|
||||
[else
|
||||
(setup-state the-state)
|
||||
(values cell-connections
|
||||
(apply vector (reverse rows))
|
||||
table-column-breaks
|
||||
initial-space-count)])))
|
||||
|
||||
(struct guide (char srcloc) #:transparent)
|
||||
|
||||
|
||||
;; parse-2dcond returns three values:
|
||||
;; - a hash table encoding a graph that shows where the
|
||||
;; broken walls are in the 2d
|
||||
;; - a vector of lists of strings containing the all of the line
|
||||
;; of the table except the last one; the first string in each
|
||||
;; list is the boundary line between the two rows
|
||||
;; - a list of numbers showing the size of each column, not
|
||||
;; counting the separator character (and not taking into
|
||||
;; acount broken walls)
|
||||
;; - the number of spaces to the left of the 2d (same for all lines)
|
||||
(define (parse-2dcond-one-step port source _line _col _pos the-state last-left-map)
|
||||
|
||||
;; this sets up all of the state variables so they
|
||||
;; look up the fields of 'the-state' and mutate
|
||||
;; the fields of 'the-state'; state-components lists
|
||||
;; of the state variables and their initial values
|
||||
(setup-state the-state)
|
||||
|
||||
|
||||
(define (add-node col row)
|
||||
(define k (list col row))
|
||||
(unless (hash-ref cell-connections k #f)
|
||||
(hash-set! cell-connections k (set))))
|
||||
(define (add-edge col1 row1 col2 row2)
|
||||
(define (add-->edge col1 row1 col2 row2)
|
||||
(add-node col1 row1)
|
||||
(define k (list col1 row1))
|
||||
(hash-set! cell-connections k (set-add (hash-ref cell-connections k) (list col2 row2))))
|
||||
(add-->edge col1 row1 col2 row2)
|
||||
(add-->edge col2 row2 col1 row1))
|
||||
|
||||
(define (fetch-next-line)
|
||||
(when current-line
|
||||
(set! pending-row (cons current-line pending-row)))
|
||||
(set! current-line-start-position
|
||||
(+ current-line-start-position
|
||||
current-line-length
|
||||
newline-char-count))
|
||||
(when current-line-number
|
||||
(set! current-line-number (+ current-line-number 1)))
|
||||
(define chars
|
||||
(let loop ([chars-read 0])
|
||||
(define c (read-char port))
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(raise-read-eof-error
|
||||
"expected eof; "
|
||||
source _line _col _pos
|
||||
(and _pos (- _pos (+ current-line-start-position chars-read))))]
|
||||
[(equal? c #\return)
|
||||
(cond
|
||||
[(equal? #\newline (peek-char port))
|
||||
(set! newline-char-count 2)
|
||||
(list c (read-char port))]
|
||||
[else
|
||||
(set! newline-char-count 1)
|
||||
(list c)])]
|
||||
[(equal? c #\newline)
|
||||
(set! newline-char-count 1)
|
||||
(list c)]
|
||||
[(and (equal? c #\╝) (equal? right-edge-column chars-read))
|
||||
;; if we find a ╝ at the width of the table,
|
||||
;; then we don't want
|
||||
;; to consume any more characters and
|
||||
;; instead to allow subsequent characters
|
||||
;; to be part of some other thing that's
|
||||
;; being read (presumably a close paren)
|
||||
(set! newline-char-count 0)
|
||||
(list c)]
|
||||
[else
|
||||
(cons c (loop (+ chars-read 1)))])))
|
||||
(set! current-line (apply string chars))
|
||||
(set! current-line-length (- (string-length current-line) newline-char-count)))
|
||||
|
||||
(define (process-first-line)
|
||||
(fetch-next-line)
|
||||
(let loop ([pos 0])
|
||||
(cond
|
||||
[(< pos current-line-length)
|
||||
(cond
|
||||
[(equal? #\space (string-ref current-line pos))
|
||||
(loop (+ pos 1))]
|
||||
[(equal? #\╔ (string-ref current-line pos))
|
||||
(set! initial-column-guide (make-a-guide pos))
|
||||
(set! initial-space-count pos)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected the first non-whitespace character in the table to be ╔"
|
||||
pos)])]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected some non-whitespace characters in the first line of the table"
|
||||
0
|
||||
pos)]))
|
||||
(let loop ([pos (+ initial-space-count 1)]
|
||||
[current-column-width 0]
|
||||
[column 0]
|
||||
[column-breaks '()]
|
||||
[column-guides '()])
|
||||
(cond
|
||||
[(< pos current-line-length)
|
||||
(case (string-ref current-line pos)
|
||||
[(#\╦)
|
||||
(add-node column 0)
|
||||
(loop (+ pos 1) 0 (+ column 1)
|
||||
(cons current-column-width column-breaks)
|
||||
(cons (make-a-guide pos) column-guides))]
|
||||
[(#\═) (loop (+ pos 1) (+ current-column-width 1) column
|
||||
column-breaks column-guides)]
|
||||
[(#\╗)
|
||||
(add-node column 0)
|
||||
(whitespace-to-end (+ pos 1))
|
||||
(set! table-column-breaks (reverse (cons current-column-width column-breaks)))
|
||||
(set! right-edge-column pos)
|
||||
(set! table-column-guides (reverse (cons (make-a-guide pos) column-guides)))]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected only ═ ╦ and ╗ characters along the top of the grid" pos)])]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected ╗ to terminate the first line" pos)])))
|
||||
|
||||
(define (process-a-line current-map)
|
||||
(fetch-next-line)
|
||||
;; check leading space
|
||||
(let loop ([n 0])
|
||||
(cond
|
||||
[(= n initial-space-count) (void)]
|
||||
[(and (< n current-line-length)
|
||||
(equal? #\space (string-ref current-line n)))
|
||||
(loop (+ n 1))]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected leading space" n)]))
|
||||
(case (string-ref current-line initial-space-count)
|
||||
[(#\║) (values (continue-line current-map) #t)]
|
||||
[(#\╠) (values (start-new-block current-map) #f)]
|
||||
[(#\╚) (values (finish-table current-map) #f)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\║ #\╠ #\╚)
|
||||
initial-space-count
|
||||
#:guides (list initial-column-guide))]))
|
||||
|
||||
(define (start-new-block previous-map)
|
||||
(set! current-row (+ current-row 1))
|
||||
(add-node 0 current-row)
|
||||
|
||||
(set! rows (cons (reverse pending-row) rows))
|
||||
(set! pending-row '())
|
||||
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[pos (+ initial-space-count 1)]
|
||||
|
||||
;; whether or not the section of the line
|
||||
;; we're currently traversing is there (or not)
|
||||
[cell-wall-broken? #f]
|
||||
|
||||
;; the srcloc of the spot that led us to the decision
|
||||
;; of which boolean that cell-wall-broken? should be
|
||||
[cell-wall-guide (make-a-guide initial-space-count)]
|
||||
|
||||
;; this is the result, being built up backwards
|
||||
[map '()]
|
||||
|
||||
;; this is the map from the previous cell;
|
||||
;; it tells us which characters here have to point upwards
|
||||
[previous-map previous-map]
|
||||
|
||||
[current-column 0])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended too soon" pos))
|
||||
(define sep (string-ref current-line pos))
|
||||
(cond
|
||||
[(and cell-wall-broken? (not (car previous-map)))
|
||||
(unless (equal? sep #\╔)
|
||||
(when (double-barred-char? sep)
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos)))]
|
||||
[else
|
||||
(define allowed-chars
|
||||
(if (null? table-column-breaks)
|
||||
(list (get-one (not cell-wall-broken?) (car previous-map) #f #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #f #t))
|
||||
(list (get-one (not cell-wall-broken?) (car previous-map) #f #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #f #t)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #t #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #t #t))))
|
||||
(unless (member sep allowed-chars)
|
||||
(line-of-interest)
|
||||
(readerr/expected (filter values allowed-chars) pos))])
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
(whitespace-to-end (+ pos 1))
|
||||
(reverse (cons #t map))]
|
||||
[else
|
||||
(define next-cell-wall-broken? (not (member sep rt-chars)))
|
||||
(define edge-going-down? (and (member sep dn-chars) #t))
|
||||
(define next-column (+ current-column 1))
|
||||
(add-node next-column current-row)
|
||||
(when next-cell-wall-broken?
|
||||
(add-edge next-column current-row
|
||||
next-column (- current-row 1)))
|
||||
(unless edge-going-down?
|
||||
(add-edge next-column current-row
|
||||
(- next-column 1) current-row))
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(+ pos 1)
|
||||
next-cell-wall-broken?
|
||||
(make-a-guide pos)
|
||||
(cons edge-going-down? map)
|
||||
(cdr previous-map)
|
||||
next-column)])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(cond
|
||||
[cell-wall-broken?
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr
|
||||
(format "expected not to find a cell boundary character (based on earlier ~a)"
|
||||
(guide-char cell-wall-guide))
|
||||
pos
|
||||
#:guides (list cell-wall-guide)))]
|
||||
[else
|
||||
(unless (equal? (string-ref current-line pos) #\═)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\═) pos #:guides (list cell-wall-guide)))])
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
(+ pos 1)
|
||||
cell-wall-broken?
|
||||
cell-wall-guide
|
||||
map
|
||||
previous-map
|
||||
current-column)])))
|
||||
|
||||
(define (continue-line map)
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[map map]
|
||||
[pos (+ initial-space-count 1)]
|
||||
[column-number 0])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended at the boundary of a cell, expected the edge of the cell" pos))
|
||||
(cond
|
||||
[(car map)
|
||||
(unless (equal? (string-ref current-line pos) #\║)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\║) pos))]
|
||||
[else
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos))])
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
(whitespace-to-end (+ pos 1))]
|
||||
[else
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(cdr map)
|
||||
(+ pos 1)
|
||||
(+ column-number 1))])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos))
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
map
|
||||
(+ pos 1)
|
||||
column-number)]))
|
||||
map)
|
||||
|
||||
|
||||
(define (finish-table map)
|
||||
(set! rows (cons (reverse pending-row) rows))
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[map map]
|
||||
[pos (+ initial-space-count 1)])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(define expected-char
|
||||
(cond
|
||||
[(null? table-column-breaks) #\╝]
|
||||
[(car map) #\╩]
|
||||
[else #\═]))
|
||||
(unless (equal? (string-ref current-line pos) expected-char)
|
||||
(line-of-interest)
|
||||
(readerr/expected (list expected-char) pos))
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
#f]
|
||||
[else
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(cdr map)
|
||||
(+ pos 1))])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(unless (equal? (string-ref current-line pos) #\═)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\═) pos))
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
map
|
||||
(+ pos 1))])))
|
||||
|
||||
(define (whitespace-to-end pos)
|
||||
(let loop ([pos pos])
|
||||
(when (< pos current-line-length)
|
||||
(define c (string-ref current-line pos))
|
||||
(cond
|
||||
[(equal? #\space c)
|
||||
(loop (+ pos 1))]
|
||||
[(equal? #\; c)
|
||||
(void)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected only whitespace outside of the table" pos)]))))
|
||||
|
||||
(define (make-a-guide pos-in-line)
|
||||
(guide (string-ref current-line pos-in-line)
|
||||
(srcloc source current-line-number pos-in-line
|
||||
(+ current-line-start-position pos-in-line)
|
||||
1)))
|
||||
|
||||
(define (readerr/expected chars pos-in-line #:guides [guides '()])
|
||||
(readerr (format "expected ~a~a~a"
|
||||
(if (null? (cdr chars))
|
||||
""
|
||||
"one of ")
|
||||
(chars->desc chars "or")
|
||||
(if (null? guides)
|
||||
""
|
||||
(format " (based on earlier ~a)"
|
||||
(chars->desc (map guide-char guides)
|
||||
"and"))))
|
||||
pos-in-line
|
||||
#:guides guides))
|
||||
|
||||
(define (readerr msg pos-in-line [span 1] #:guides [guides '()])
|
||||
(raise-read-error msg
|
||||
source
|
||||
current-line-number
|
||||
pos-in-line
|
||||
(+ current-line-start-position pos-in-line)
|
||||
span
|
||||
#:extra-srclocs (map guide-srcloc guides)))
|
||||
|
||||
(let loop ([map (or last-left-map
|
||||
(begin
|
||||
(process-first-line)
|
||||
(map (λ (x) #t) table-column-breaks)))])
|
||||
(define-values (next-map continue?) (process-a-line map))
|
||||
(cond
|
||||
[continue? (loop next-map)]
|
||||
[next-map next-map]
|
||||
[else #f])))
|
||||
|
||||
;; chars : non-empty-list-of-char -> string
|
||||
(define (chars->desc chars sep)
|
||||
(cond
|
||||
[(null? (cdr chars))
|
||||
(format "~a" (car chars))]
|
||||
[else
|
||||
(define commas? (pair? (cddr chars)))
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([chars chars]
|
||||
[first? #t])
|
||||
(cond
|
||||
[(null? (cdr chars))
|
||||
(list (format "~a~a ~a"
|
||||
(if first? "" " ")
|
||||
sep
|
||||
(car chars)))]
|
||||
[else
|
||||
(cons (format "~a~a~a"
|
||||
(if first? "" " ")
|
||||
(car chars)
|
||||
(if commas? "," ""))
|
||||
(loop (cdr chars) #f))])))]))
|
||||
|
||||
(define (double-barred-char? c) (member c double-barred-chars))
|
||||
|
||||
(define (get-one lt? up? rt? dn?)
|
||||
(define (cmb a b) (if a b (not b)))
|
||||
(for/or ([c (in-list double-barred-chars)])
|
||||
(and (cmb lt? (member c lt-chars))
|
||||
(cmb up? (member c up-chars))
|
||||
(cmb rt? (member c rt-chars))
|
||||
(cmb dn? (member c dn-chars))
|
||||
c)))
|
||||
|
|
@ -13,38 +13,14 @@ example uses:
|
|||
|
||||
|#
|
||||
|
||||
(require racket/port
|
||||
syntax/readerr
|
||||
racket/match
|
||||
(require "read-util.rkt"
|
||||
racket/set
|
||||
;syntax/rect
|
||||
"../dir-chars.rkt"
|
||||
(for-syntax racket/base
|
||||
racket/list))
|
||||
racket/port)
|
||||
|
||||
|
||||
(provide make-2d-readtable
|
||||
|
||||
;; provided for the test suite
|
||||
chars->desc
|
||||
smallest-representative
|
||||
parse-2dcond
|
||||
all-line-of-interest
|
||||
current-lines
|
||||
close-cell-graph
|
||||
compare/xy
|
||||
fill-scratch-string)
|
||||
|
||||
(define all-line-of-interest (make-hash))
|
||||
(define current-lines (make-parameter #f))
|
||||
(define-syntax (line-of-interest stx)
|
||||
(with-syntax ([line (syntax-line stx)])
|
||||
(syntax-local-lift-expression #'(hash-set! all-line-of-interest line #t))
|
||||
#'(visited line)))
|
||||
(define (visited line)
|
||||
(define t (current-lines))
|
||||
(when t
|
||||
(hash-remove! t line)))
|
||||
(provide make-2d-readtable)
|
||||
|
||||
(define (make-2d-readtable)
|
||||
(define previous-readtable (current-readtable))
|
||||
|
|
@ -61,6 +37,7 @@ example uses:
|
|||
(λ (a b c) (read-syntax/recursive source a b c))
|
||||
previous-readtable)])))
|
||||
|
||||
|
||||
(define (dispatch-proc char port source _line _col _pos /recursive previous-readtable)
|
||||
(define next-char (peek-char port))
|
||||
(cond
|
||||
|
|
@ -75,7 +52,6 @@ example uses:
|
|||
(define c (rc))
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(line-of-interest)
|
||||
(raise (make-exn:fail:read:eof
|
||||
"expected a newline to follow #2d"
|
||||
(current-continuation-marks)
|
||||
|
|
@ -89,9 +65,9 @@ example uses:
|
|||
'()]
|
||||
[else (cons c (loop))])))
|
||||
(define-values (post-2d-line post-2d-col post-2d-span) (port-next-location port))
|
||||
(define-values (edges lines table-column-breaks initial-space-count)
|
||||
(define-values (cell-connections lines table-column-breaks initial-space-count)
|
||||
(parse-2dcond port source _line _col _pos chars-read))
|
||||
(define lhses (close-cell-graph edges (length table-column-breaks) (vector-length lines)))
|
||||
(define lhses (close-cell-graph cell-connections (length table-column-breaks) (vector-length lines)))
|
||||
(define scratch-string (make-string (for/sum ([ss (in-vector lines)])
|
||||
(for/sum ([s (in-list ss)])
|
||||
(string-length s)))
|
||||
|
|
@ -126,6 +102,7 @@ example uses:
|
|||
#f
|
||||
previous-readtable)]))
|
||||
|
||||
|
||||
(define (read-subparts source scratch-port
|
||||
initial-space-count table-column-breaks heights lhs
|
||||
previous-readtable /recursive)
|
||||
|
|
@ -160,531 +137,3 @@ example uses:
|
|||
(list-ref table-column-breaks x)
|
||||
(list-ref heights y))))
|
||||
|
||||
(define (fill-scratch-string set-of-indicies
|
||||
lines
|
||||
scratch-string
|
||||
table-column-breaks
|
||||
initial-space-count)
|
||||
(define scratch-pos 0)
|
||||
(define-syntax-rule
|
||||
(set-scratch! c)
|
||||
(let ([x c])
|
||||
;(unless (char-whitespace? x) (printf "putting ~s @ ~s\n" x scratch-pos))
|
||||
(string-set! scratch-string scratch-pos x)))
|
||||
(define-syntax-rule
|
||||
(inc-scratch-pos! e)
|
||||
(set! scratch-pos (+ scratch-pos e)))
|
||||
(for ([lines (in-vector lines)]
|
||||
[y (in-naturals)])
|
||||
(for ([line (in-list lines)]
|
||||
[l-num (in-naturals)])
|
||||
(define first-line? (zero? l-num))
|
||||
;; skip over initial spaces: we know that the string is already right here
|
||||
;; because it is initialized with spaces and never changed
|
||||
;; the +1 is for the first character (in the current line)
|
||||
;; of the table, which is always a table edge character
|
||||
(inc-scratch-pos! (+ initial-space-count 1))
|
||||
(define end-of-table-position
|
||||
(for/fold ([start-pos-in-line (+ initial-space-count 1)])
|
||||
([table-column-break (in-list table-column-breaks)]
|
||||
[x (in-naturals)])
|
||||
(cond
|
||||
[(and (set-member? set-of-indicies (list x y))
|
||||
(or (not first-line?)
|
||||
(set-member? set-of-indicies (list x (- y 1)))))
|
||||
(for ([j (in-range table-column-break)])
|
||||
(set-scratch! (string-ref line (+ j start-pos-in-line)))
|
||||
(inc-scratch-pos! 1))
|
||||
;(printf "first-line? ~s x ~s y ~s\n" first-line? x y)
|
||||
(set-scratch! (if (if first-line?
|
||||
(and (set-member? set-of-indicies (list (+ x 1) (- y 1)))
|
||||
(set-member? set-of-indicies (list (+ x 1) y))
|
||||
(set-member? set-of-indicies (list x (- y 1))))
|
||||
(set-member? set-of-indicies (list (+ x 1) y)))
|
||||
(string-ref line (+ table-column-break start-pos-in-line))
|
||||
#\space))
|
||||
;(printf "set\n")
|
||||
(inc-scratch-pos! 1)]
|
||||
[else
|
||||
(for ([j (in-range table-column-break)])
|
||||
(set-scratch! #\space)
|
||||
(inc-scratch-pos! 1))
|
||||
(set-scratch! #\space)
|
||||
(inc-scratch-pos! 1)])
|
||||
(+ start-pos-in-line table-column-break 1)))
|
||||
(for ([j (in-range end-of-table-position (string-length line))])
|
||||
(set-scratch! (string-ref line j))
|
||||
(inc-scratch-pos! 1)))))
|
||||
|
||||
(define (compare/xy p1 p2)
|
||||
(cond
|
||||
[(= (list-ref p1 0) (list-ref p2 0))
|
||||
(< (list-ref p1 1) (list-ref p2 1))]
|
||||
[else
|
||||
(< (list-ref p1 0) (list-ref p2 0))]))
|
||||
|
||||
(define (smallest-representative set)
|
||||
(define lst (set->list set))
|
||||
(let loop ([best (car lst)]
|
||||
[rest (cdr lst)])
|
||||
(cond
|
||||
[(null? rest) best]
|
||||
[else
|
||||
(cond
|
||||
[(compare/xy best (car rest))
|
||||
(loop best (cdr rest))]
|
||||
[else
|
||||
(loop (car rest) (cdr rest))])])))
|
||||
|
||||
(define (close-cell-graph edges width height)
|
||||
(define res (make-hash))
|
||||
(for ([x (in-range width)])
|
||||
(for ([y (in-range height)])
|
||||
(hash-set! res (list x y) (set (list x y)))))
|
||||
|
||||
(let loop ()
|
||||
(define something-changed? #f)
|
||||
(define (add-all n1 n2)
|
||||
(define in-n1 (hash-ref res n1))
|
||||
(define in-n2 (hash-ref res n2))
|
||||
(for ([new-node (in-set in-n1)])
|
||||
(unless (set-member? in-n2 new-node)
|
||||
(set! something-changed? #t)
|
||||
(hash-set! res n2 (set-add in-n2 new-node)))))
|
||||
|
||||
(for ([(node-src nodes) (in-hash edges)])
|
||||
(for ([node-dest (in-set nodes)])
|
||||
(add-all node-dest node-src)
|
||||
(add-all node-src node-dest)))
|
||||
|
||||
(when something-changed? (loop)))
|
||||
|
||||
(apply set (hash-map res (λ (x y) y))))
|
||||
|
||||
;; parse-2dcond returns three values:
|
||||
;; - a hash table encoding a graph that shows where the
|
||||
;; broken walls are in the 2d
|
||||
;; - a vector of lists of strings containing the all of the line
|
||||
;; of the table except the last one; the first string in each
|
||||
;; list is the boundary line between the two rows
|
||||
;; - a list of numbers showing the size of each column, not
|
||||
;; counting the separator character (and not taking into
|
||||
;; acount broken walls)
|
||||
;; - the number of spaces to the left of the 2d (same for all lines)
|
||||
(define (parse-2dcond port source _line _col _pos chars-read)
|
||||
(define current-line-number _line)
|
||||
(define current-line-start-position (+ (or _pos 0) chars-read))
|
||||
(define current-line #f)
|
||||
(define current-line-length 0)
|
||||
(define initial-space-count 0)
|
||||
(define initial-column-guide #f)
|
||||
(define newline-char-count 0)
|
||||
(define table-column-breaks '())
|
||||
(define table-column-guides '())
|
||||
(define right-edge-column #f)
|
||||
|
||||
;; saving the previous lines to build
|
||||
;; the result for this function
|
||||
(define pending-row '())
|
||||
(define rows '())
|
||||
|
||||
(define current-row 0)
|
||||
(define cell-connections (make-hash))
|
||||
(define (add-node col row)
|
||||
(define k (list col row))
|
||||
(unless (hash-ref cell-connections k #f)
|
||||
(hash-set! cell-connections k (set))))
|
||||
(define (add-edge col1 row1 col2 row2)
|
||||
(define (add-->edge col1 row1 col2 row2)
|
||||
(add-node col1 row1)
|
||||
(define k (list col1 row1))
|
||||
(hash-set! cell-connections k (set-add (hash-ref cell-connections k) (list col2 row2))))
|
||||
(add-->edge col1 row1 col2 row2)
|
||||
(add-->edge col2 row2 col1 row1))
|
||||
|
||||
(define (fetch-next-line)
|
||||
(when current-line
|
||||
(set! pending-row (cons current-line pending-row)))
|
||||
(set! current-line-start-position
|
||||
(+ current-line-start-position
|
||||
current-line-length
|
||||
newline-char-count))
|
||||
(when current-line-number
|
||||
(set! current-line-number (+ current-line-number 1)))
|
||||
(define chars
|
||||
(let loop ([chars-read 0])
|
||||
(define c (read-char port))
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(raise-read-eof-error
|
||||
"expected eof; "
|
||||
source _line _col _pos
|
||||
(and _pos (- _pos (+ current-line-start-position chars-read))))]
|
||||
[(equal? c #\return)
|
||||
(cond
|
||||
[(equal? #\newline (peek-char port))
|
||||
(set! newline-char-count 2)
|
||||
(list c (read-char port))]
|
||||
[else
|
||||
(set! newline-char-count 1)
|
||||
(list c)])]
|
||||
[(equal? c #\newline)
|
||||
(set! newline-char-count 1)
|
||||
(list c)]
|
||||
[(and (equal? c #\╝) (equal? right-edge-column chars-read))
|
||||
;; if we find a ╝ at the width of the table,
|
||||
;; then we don't want
|
||||
;; to consume any more characters and
|
||||
;; instead to allow subsequent characters
|
||||
;; to be part of some other thing that's
|
||||
;; being read (presumably a close paren)
|
||||
(set! newline-char-count 0)
|
||||
(list c)]
|
||||
[else
|
||||
(cons c (loop (+ chars-read 1)))])))
|
||||
(set! current-line (apply string chars))
|
||||
(set! current-line-length (- (string-length current-line) newline-char-count)))
|
||||
|
||||
(define (process-first-line)
|
||||
(fetch-next-line)
|
||||
(let loop ([pos 0])
|
||||
(cond
|
||||
[(< pos current-line-length)
|
||||
(cond
|
||||
[(equal? #\space (string-ref current-line pos))
|
||||
(loop (+ pos 1))]
|
||||
[(equal? #\╔ (string-ref current-line pos))
|
||||
(set! initial-column-guide (make-a-guide pos))
|
||||
(set! initial-space-count pos)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected the first non-whitespace character in the table to be ╔"
|
||||
pos)])]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected some non-whitespace characters in the first line of the table"
|
||||
0
|
||||
pos)]))
|
||||
(let loop ([pos (+ initial-space-count 1)]
|
||||
[current-column-width 0]
|
||||
[column 0]
|
||||
[column-breaks '()]
|
||||
[column-guides '()])
|
||||
(cond
|
||||
[(< pos current-line-length)
|
||||
(case (string-ref current-line pos)
|
||||
[(#\╦)
|
||||
(add-node column 0)
|
||||
(loop (+ pos 1) 0 (+ column 1)
|
||||
(cons current-column-width column-breaks)
|
||||
(cons (make-a-guide pos) column-guides))]
|
||||
[(#\═) (loop (+ pos 1) (+ current-column-width 1) column
|
||||
column-breaks column-guides)]
|
||||
[(#\╗)
|
||||
(add-node column 0)
|
||||
(whitespace-to-end (+ pos 1))
|
||||
(set! table-column-breaks (reverse (cons current-column-width column-breaks)))
|
||||
(set! right-edge-column pos)
|
||||
(set! table-column-guides (reverse (cons (make-a-guide pos) column-guides)))])]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected ╗ to terminate the first line" pos)])))
|
||||
|
||||
(define (process-a-line current-map)
|
||||
(fetch-next-line)
|
||||
;; check leading space
|
||||
(let loop ([n 0])
|
||||
(cond
|
||||
[(= n initial-space-count) (void)]
|
||||
[(and (< n current-line-length)
|
||||
(equal? #\space (string-ref current-line n)))
|
||||
(loop (+ n 1))]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected leading space" n)]))
|
||||
(case (string-ref current-line initial-space-count)
|
||||
[(#\║) (continue-line current-map)]
|
||||
[(#\╠) (start-new-block current-map)]
|
||||
[(#\╚) (finish-table current-map)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\║ #\╠ #\╚)
|
||||
initial-space-count
|
||||
#:guides (list initial-column-guide))]))
|
||||
|
||||
(define (start-new-block previous-map)
|
||||
(set! current-row (+ current-row 1))
|
||||
(add-node 0 current-row)
|
||||
|
||||
(set! rows (cons (reverse pending-row) rows))
|
||||
(set! pending-row '())
|
||||
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[pos (+ initial-space-count 1)]
|
||||
|
||||
;; whether or not the section of the line
|
||||
;; we're currently traversing is there (or not)
|
||||
[cell-wall-broken? #f]
|
||||
|
||||
;; the srcloc of the spot that led us to the decision
|
||||
;; of which boolean that cell-wall-broken? should be
|
||||
[cell-wall-guide (make-a-guide initial-space-count)]
|
||||
|
||||
;; this is the result, being built up backwards
|
||||
[map '()]
|
||||
|
||||
;; this is the map from the previous cell;
|
||||
;; it tells us which characters here have to point upwards
|
||||
[previous-map previous-map]
|
||||
|
||||
[current-column 0])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended too soon" pos))
|
||||
(define sep (string-ref current-line pos))
|
||||
(cond
|
||||
[(and cell-wall-broken? (not (car previous-map)))
|
||||
(unless (equal? sep #\╔)
|
||||
(when (double-barred-char? sep)
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos)))]
|
||||
[else
|
||||
(define allowed-chars
|
||||
(if (null? table-column-breaks)
|
||||
(list (get-one (not cell-wall-broken?) (car previous-map) #f #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #f #t))
|
||||
(list (get-one (not cell-wall-broken?) (car previous-map) #f #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #f #t)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #t #f)
|
||||
(get-one (not cell-wall-broken?) (car previous-map) #t #t))))
|
||||
(unless (member sep allowed-chars)
|
||||
(line-of-interest)
|
||||
(readerr/expected (filter values allowed-chars) pos))])
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
(whitespace-to-end (+ pos 1))
|
||||
(reverse (cons #t map))]
|
||||
[else
|
||||
(define next-cell-wall-broken? (not (member sep rt-chars)))
|
||||
(define edge-going-down? (and (member sep dn-chars) #t))
|
||||
(define next-column (+ current-column 1))
|
||||
(add-node next-column current-row)
|
||||
(when next-cell-wall-broken?
|
||||
(add-edge next-column current-row
|
||||
next-column (- current-row 1)))
|
||||
(unless edge-going-down?
|
||||
(add-edge next-column current-row
|
||||
(- next-column 1) current-row))
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(+ pos 1)
|
||||
next-cell-wall-broken?
|
||||
(make-a-guide pos)
|
||||
(cons edge-going-down? map)
|
||||
(cdr previous-map)
|
||||
next-column)])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(cond
|
||||
[cell-wall-broken?
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr
|
||||
(format "expected not to find a cell boundary character (based on earlier ~a)"
|
||||
(guide-char cell-wall-guide))
|
||||
pos
|
||||
#:guides (list cell-wall-guide)))]
|
||||
[else
|
||||
(unless (equal? (string-ref current-line pos) #\═)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\═) pos #:guides (list cell-wall-guide)))])
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
(+ pos 1)
|
||||
cell-wall-broken?
|
||||
cell-wall-guide
|
||||
map
|
||||
previous-map
|
||||
current-column)])))
|
||||
|
||||
(define (continue-line map)
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[map map]
|
||||
[pos (+ initial-space-count 1)]
|
||||
[column-number 0])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended at the boundary of a cell, expected the edge of the cell" pos))
|
||||
(cond
|
||||
[(car map)
|
||||
(unless (equal? (string-ref current-line pos) #\║)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\║) pos))]
|
||||
[else
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos))])
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
(whitespace-to-end (+ pos 1))]
|
||||
[else
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(cdr map)
|
||||
(+ pos 1)
|
||||
(+ column-number 1))])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(when (double-barred-char? (string-ref current-line pos))
|
||||
(line-of-interest)
|
||||
(readerr "expected not to find a cell boundary character" pos))
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
map
|
||||
(+ pos 1)
|
||||
column-number)]))
|
||||
map)
|
||||
|
||||
|
||||
(define (finish-table map)
|
||||
(set! rows (cons (reverse pending-row) rows))
|
||||
(let loop ([current-cell-size (car table-column-breaks)]
|
||||
[table-column-breaks (cdr table-column-breaks)]
|
||||
[map map]
|
||||
[pos (+ initial-space-count 1)])
|
||||
(cond
|
||||
[(zero? current-cell-size)
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(define expected-char
|
||||
(cond
|
||||
[(null? table-column-breaks) #\╝]
|
||||
[(car map) #\╩]
|
||||
[else #\═]))
|
||||
(unless (equal? (string-ref current-line pos) expected-char)
|
||||
(line-of-interest)
|
||||
(readerr/expected (list expected-char) pos))
|
||||
(cond
|
||||
[(null? table-column-breaks)
|
||||
#f]
|
||||
[else
|
||||
(loop (car table-column-breaks)
|
||||
(cdr table-column-breaks)
|
||||
(cdr map)
|
||||
(+ pos 1))])]
|
||||
[else
|
||||
(unless (< pos current-line-length)
|
||||
(line-of-interest)
|
||||
(readerr "line ended in the middle of a cell" pos))
|
||||
(unless (equal? (string-ref current-line pos) #\═)
|
||||
(line-of-interest)
|
||||
(readerr/expected '(#\═) pos))
|
||||
(loop (- current-cell-size 1)
|
||||
table-column-breaks
|
||||
map
|
||||
(+ pos 1))])))
|
||||
|
||||
(define (whitespace-to-end pos)
|
||||
(let loop ([pos pos])
|
||||
(when (< pos current-line-length)
|
||||
(define c (string-ref current-line pos))
|
||||
(cond
|
||||
[(equal? #\space c)
|
||||
(loop (+ pos 1))]
|
||||
[(equal? #\; c)
|
||||
(void)]
|
||||
[else
|
||||
(line-of-interest)
|
||||
(readerr "expected only whitespace outside of the table" pos)]))))
|
||||
|
||||
(struct guide (char srcloc))
|
||||
|
||||
(define (make-a-guide pos-in-line)
|
||||
(guide (string-ref current-line pos-in-line)
|
||||
(srcloc source current-line-number pos-in-line
|
||||
(+ current-line-start-position pos-in-line)
|
||||
1)))
|
||||
|
||||
(define (readerr/expected chars pos-in-line #:guides [guides '()])
|
||||
(readerr (format "expected ~a~a~a"
|
||||
(if (null? (cdr chars))
|
||||
""
|
||||
"one of ")
|
||||
(chars->desc chars "or")
|
||||
(if (null? guides)
|
||||
""
|
||||
(format " (based on earlier ~a)"
|
||||
(chars->desc (map guide-char guides)
|
||||
"and"))))
|
||||
pos-in-line
|
||||
#:guides guides))
|
||||
|
||||
(define (readerr msg pos-in-line [span 1] #:guides [guides '()])
|
||||
(raise-read-error msg
|
||||
source
|
||||
current-line-number
|
||||
pos-in-line
|
||||
(+ current-line-start-position pos-in-line)
|
||||
span
|
||||
#:extra-srclocs (map guide-srcloc guides)))
|
||||
|
||||
(process-first-line)
|
||||
(let loop ([map (map (λ (x) #t) table-column-breaks)])
|
||||
(define next-map (process-a-line map))
|
||||
(cond
|
||||
[next-map (loop next-map)]
|
||||
[else
|
||||
(values cell-connections
|
||||
(apply vector (reverse rows))
|
||||
table-column-breaks
|
||||
initial-space-count)])))
|
||||
|
||||
|
||||
|
||||
|
||||
;; chars : non-empty-list-of-char -> string
|
||||
(define (chars->desc chars sep)
|
||||
(cond
|
||||
[(null? (cdr chars))
|
||||
(format "~a" (car chars))]
|
||||
[else
|
||||
(define commas? (pair? (cddr chars)))
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([chars chars]
|
||||
[first? #t])
|
||||
(cond
|
||||
[(null? (cdr chars))
|
||||
(list (format "~a~a ~a"
|
||||
(if first? "" " ")
|
||||
sep
|
||||
(car chars)))]
|
||||
[else
|
||||
(cons (format "~a~a~a"
|
||||
(if first? "" " ")
|
||||
(car chars)
|
||||
(if commas? "," ""))
|
||||
(loop (cdr chars) #f))])))]))
|
||||
|
||||
(define (double-barred-char? c) (member c double-barred-chars))
|
||||
|
||||
(define (get-one lt? up? rt? dn?)
|
||||
(define (cmb a b) (if a b (not b)))
|
||||
(for/or ([c (in-list double-barred-chars)])
|
||||
(and (cmb lt? (member c lt-chars))
|
||||
(cmb up? (member c up-chars))
|
||||
(cmb rt? (member c rt-chars))
|
||||
(cmb dn? (member c dn-chars))
|
||||
c)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user