2d
This commit is contained in:
Robby Findler
parent
0531412a8e
commit
bb216d142c
83
collects/tests/unstable/2d/cond-test.rkt
Normal file
83
collects/tests/unstable/2d/cond-test.rkt
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
#lang unstable/2d racket/base
|
||||
(require unstable/2d/cond
|
||||
rackunit)
|
||||
|
||||
(define (basic a b c d)
|
||||
#2dcond
|
||||
╔═══╦═══╦═══╗
|
||||
║ ║ a ║ b ║
|
||||
╠═══╬═══╬═══╣
|
||||
║ c ║ 1 ║ 2 ║
|
||||
╠═══╬═══╬═══╣
|
||||
║ d ║ 3 ║ 4 ║
|
||||
╚═══╩═══╩═══╝)
|
||||
|
||||
(define ((matches reg) exn) (regexp-match? reg (exn-message exn)))
|
||||
|
||||
(check-equal? (basic #t #t #t #t) 1)
|
||||
(check-equal? (basic #t #f #t #f) 1)
|
||||
(check-equal? (basic #f #t #t #t) 2)
|
||||
(check-equal? (basic #f #t #t #f) 2)
|
||||
(check-equal? (basic #t #t #f #t) 3)
|
||||
(check-equal? (basic #t #f #f #t) 3)
|
||||
(check-equal? (basic #f #t #f #t) 4)
|
||||
(check-exn (matches #rx"x-direction questions")
|
||||
(λ () (basic #f #f #f #f)))
|
||||
(check-exn (matches #rx"y-direction questions.*x coordinate 1")
|
||||
(λ () (basic #t #f #f #f)))
|
||||
(check-exn (matches #rx"y-direction questions.*x coordinate 2")
|
||||
(λ () (basic #f #t #f #f)))
|
||||
|
||||
(define (bot-right-cell a b c d)
|
||||
#2dcond
|
||||
╔═══╦═══╦═══╗
|
||||
║ ║ a ║ b ║
|
||||
╠═══╬═══╩═══╣
|
||||
║ c ║ 1 ║
|
||||
╠═══╣ ╔═══╣
|
||||
║ d ║ ║ 2 ║
|
||||
╚═══╩═══╩═══╝)
|
||||
|
||||
(check-equal? (bot-right-cell #t #t #t #t) 1)
|
||||
(check-equal? (bot-right-cell #t #f #t #f) 1)
|
||||
(check-equal? (bot-right-cell #f #t #t #t) 1)
|
||||
(check-equal? (bot-right-cell #f #t #t #f) 1)
|
||||
(check-equal? (bot-right-cell #t #t #f #t) 1)
|
||||
(check-equal? (bot-right-cell #t #f #f #t) 1)
|
||||
(check-equal? (bot-right-cell #f #t #f #t) 2)
|
||||
|
||||
(define (top-left-cell a b c d)
|
||||
#2dcond
|
||||
╔═══╦═══╦═══╗
|
||||
║ ║ a ║ b ║
|
||||
╠═══╬═══╬═══╣
|
||||
║ c ║ 1 ║ ║
|
||||
╠═══╬═══╝ ║
|
||||
║ d ║ 2 ║
|
||||
╚═══╩═══════╝)
|
||||
|
||||
(check-equal? (top-left-cell #t #t #t #t) 1)
|
||||
(check-equal? (top-left-cell #t #f #t #f) 1)
|
||||
(check-equal? (top-left-cell #f #t #t #t) 2)
|
||||
(check-equal? (top-left-cell #f #t #t #f) 2)
|
||||
(check-equal? (top-left-cell #t #t #f #t) 2)
|
||||
(check-equal? (top-left-cell #t #f #f #t) 2)
|
||||
(check-equal? (top-left-cell #f #t #f #t) 2)
|
||||
|
||||
(let ([sp (open-output-string)])
|
||||
(define (f x) (printf "~a\n" x) #f)
|
||||
(parameterize ([current-output-port sp])
|
||||
#2dcond
|
||||
╔═════╦═══════╦═══════╦════╗
|
||||
║ ║ (f 1) ║ (f 2) ║ #t ║
|
||||
╠═════╬═══════╩═══════╩════╣
|
||||
║(f 3)║ ║
|
||||
╠═════╣ ║
|
||||
║(f 4)║ 222 ║
|
||||
╠═════╣ ║
|
||||
║ #t ║ ║
|
||||
╚═════╩════════════════════╝)
|
||||
(check-equal? (get-output-string sp)
|
||||
"1\n2\n3\n4\n"))
|
||||
|
||||
|
||||
37
collects/tests/unstable/2d/match-test.rkt
Normal file
37
collects/tests/unstable/2d/match-test.rkt
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#lang unstable/2d racket
|
||||
(require unstable/2d/match
|
||||
rackunit)
|
||||
|
||||
(check-equal?
|
||||
#2dmatch
|
||||
╔═══════╦══════╦══════════╗
|
||||
║ 1 ║ 'x ║ x ║
|
||||
║ 2 ║ ║ ║
|
||||
╠═══════╬══════╬══════════╣
|
||||
║ y ║ #f ║(list x y)║
|
||||
╚═══════╩══════╩══════════╝
|
||||
(list 1 2))
|
||||
|
||||
(define (≤ t1 t2)
|
||||
#2dmatch
|
||||
╔══════════╦══════╦═══════╦══════════╦═════════════════╗
|
||||
║ t2 ║ 'Int ║ 'Real ║ 'Complex ║ `(-> ,t2d ║
|
||||
║ t1 ║ ║ ║ ║ ,t2r) ║
|
||||
╠══════════╬══════╩═══════╩══════════╬═════════════════╣
|
||||
║ 'Int ║ ║ ║
|
||||
╠══════════╬══════╗ #t ║ ║
|
||||
║ 'Real ║ ║ ║ #f ║
|
||||
╠══════════╣ ╚═══════╗ ║ ║
|
||||
║'Complex ║ ║ ║ ║
|
||||
╠══════════╣ ╚══════════╬═════════════════╣
|
||||
║`(-> ,t1d ║ #f ║(and (≤ t2d t1d) ║
|
||||
║ ,t1r)║ ║ (≤ t1r t2r))║
|
||||
╚══════════╩═════════════════════════╩═════════════════╝)
|
||||
|
||||
(check-equal? (≤ 'Int 'Int) #t)
|
||||
(check-equal? (≤ 'Int 'Real) #t)
|
||||
(check-equal? (≤ 'Real 'Int) #f)
|
||||
(check-equal? (≤ 'Complex 'Complex) #t)
|
||||
(check-equal? (≤ 'Complex 'Int) #f)
|
||||
(check-equal? (≤ '(-> Real Int) '(-> Int Real)) #t)
|
||||
(check-equal? (≤ '(-> Int Complex) '(-> Int Real)) #f)
|
||||
664
collects/tests/unstable/2d/readtable-test.rkt
Normal file
664
collects/tests/unstable/2d/readtable-test.rkt
Normal file
|
|
@ -0,0 +1,664 @@
|
|||
#lang racket/base
|
||||
|
||||
(require rackunit
|
||||
unstable/2d/private/readtable
|
||||
racket/set)
|
||||
|
||||
(define touched-lines-table (make-hash))
|
||||
|
||||
(check-equal? (chars->desc '(#\a) "or")
|
||||
"a")
|
||||
(check-equal? (chars->desc '(#\a #\b) "or")
|
||||
"a or b")
|
||||
(check-equal? (chars->desc '(#\a #\b #\c) "or")
|
||||
"a, b, or c")
|
||||
(check-equal? (chars->desc '(#\a #\b #\c #\d) "or")
|
||||
"a, b, c, or d")
|
||||
(check-equal? (chars->desc '(#\a #\b #\c #\d #\e) "or")
|
||||
"a, b, c, d, or e")
|
||||
|
||||
(check-equal? (read (open-input-string "#2(x)"))
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(read (open-input-string "#2(x)"))))
|
||||
(check-equal? (with-handlers ((exn:fail? exn-message))
|
||||
(read (open-input-string "#2x(x)")))
|
||||
(with-handlers ((exn:fail? exn-message))
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(read (open-input-string "#2x(x)")))))
|
||||
(check-true (syntax? (read-syntax 'hi (open-input-string "#2(x)"))))
|
||||
(check-equal? (read (open-input-string "#2(x)"))
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(syntax->datum (read-syntax 'hi (open-input-string "#2(x)")))))
|
||||
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(define sp (open-input-string
|
||||
(string-append "#2d\n"
|
||||
"╔══╦══╗\n"
|
||||
"║1 ║2 ║\n"
|
||||
"╠══╬══╣\n"
|
||||
"║4 ║3 ║\n"
|
||||
"╚══╩══╝\n")))
|
||||
(define wp
|
||||
(make-input-port 'name sp sp void #f #f
|
||||
(λ () (values #f #f #f))
|
||||
void))
|
||||
(port-count-lines! wp)
|
||||
;; make sure that if there is no source location information,
|
||||
;; we still get some result back.
|
||||
(check-true (pair? (read wp))))
|
||||
|
||||
(define (get-err-locs inputs)
|
||||
(with-handlers ([exn:fail:read? exn:fail:read-srclocs])
|
||||
(define p (open-input-string (apply string-append inputs)))
|
||||
(port-count-lines! p)
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(read-syntax #f p))
|
||||
#f))
|
||||
|
||||
(define (get-something inputs i)
|
||||
(define p (open-input-string (apply string-append inputs)))
|
||||
(port-count-lines! p)
|
||||
;; account for the "#2d" that was read from the first line
|
||||
(call-with-values (λ () (parse-2dcond p "source" 1 0 1 2))
|
||||
(λ x (list-ref x i))))
|
||||
|
||||
(define (get-graph inputs) (get-something inputs 0))
|
||||
(define (get-all-lines inputs) (get-something inputs 1))
|
||||
(define (get-table-column-breaks inputs) (get-something inputs 2))
|
||||
(define (get-initial-space-count inputs) (get-something inputs 3))
|
||||
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
"╔══╦══╗\n"
|
||||
"║1 ║2 ║\n"
|
||||
"╠══╬══╣\n"
|
||||
"║4 ║3 ║\n"
|
||||
"╚══╩══╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
"╔══╦══╗\n"
|
||||
"║λ ║2 ║\n"
|
||||
"╠══╬══╣\n"
|
||||
"║1 ║黃 ║\n"
|
||||
"╚══╩══╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║1 ║4 ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║2 ║3 ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦══╗\n"
|
||||
" ║1 ║2 ║3 ║\n"
|
||||
" ╠══╬══╬══╣\n"
|
||||
" ║6 ║5 ║4 ║\n"
|
||||
" ╠══╬══╬══╣\n"
|
||||
" ║7 ║8 ║9 ║\n"
|
||||
" ╚══╩══╩══╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦══╗\n"
|
||||
" ║ 1║ 2║ 3║\n"
|
||||
" ╠══╬══╩══╣\n"
|
||||
" ║ 4║ ║\n"
|
||||
" ╠══╣ 6 ║\n"
|
||||
" ║ 5║ ║\n"
|
||||
" ╚══╩═════╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦══╗\n"
|
||||
" ║ 1║ 2║ 3║\n"
|
||||
" ╠══╬══╩══╣\n"
|
||||
" ║ 4║5 ║\n"
|
||||
" ╠══╬═════╣\n"
|
||||
" ║ 6║7 ║\n"
|
||||
" ╚══╩═════╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦══╦══╗\n"
|
||||
" ║ 1║ 2║ 3║ 4║\n"
|
||||
" ╠══╬══╬══╩══╣\n"
|
||||
" ║ 4║ 5║ 6 ║\n"
|
||||
" ╚══╩══╩═════╝\n"))
|
||||
#f)
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦══╗\n"
|
||||
" ║1 ║2 ║3 ║\n"
|
||||
" ╠══╬══╬══╣\n"
|
||||
" ║4 ║ ║ ║\n"
|
||||
" ╠══╣ ║ ║\n"
|
||||
" ║5 ║6 ║7 ║\n"
|
||||
" ╚══╩══╩══╝\n"))
|
||||
#f)
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║1 ║4 ║ ;; comment\n"
|
||||
" ╠══╬══╣ ;; comment \n"
|
||||
" ║2 ║3 ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
#f)
|
||||
|
||||
(define lines-table (hash-copy all-line-of-interest))
|
||||
|
||||
(parameterize ([current-lines lines-table])
|
||||
(check-regexp-match #rx"expected a newline"
|
||||
(with-handlers ((exn:fail? exn-message))
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(read (open-input-string "#2d")))))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list (srcloc #f 3 2 17 1)
|
||||
(srcloc #f 2 2 7 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║ ═║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list (srcloc #f 3 4 19 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list (srcloc #f 3 1 16 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╬══\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list (srcloc #f 4 8 33 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠═\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list (srcloc #f 4 4 29 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" +----+\n"
|
||||
" | |\n"
|
||||
" +----+\n"))
|
||||
(list (srcloc #f 2 2 7 1)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" \n"))
|
||||
(list (srcloc #f 2 0 5 3)))
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══\n"))
|
||||
(list (srcloc #f 2 8 13 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬══╩═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╣ ═ ║\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══════╝\n"))
|
||||
(list (srcloc #f 6 8 69 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬══╩═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╬══╝═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══╩══════╝\n"))
|
||||
(list (srcloc #f 6 8 69 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╣ ═ ╠═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 6 7 72 1)
|
||||
(srcloc #f 6 5 70 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬═ ═╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 6 7 72 1)
|
||||
(srcloc #f 6 5 70 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╬═══╬═══╣\n"
|
||||
" ║ ║ ║ \n"
|
||||
" ╠══╬═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 5 13 63 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ║ ║\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╦═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 6 9 74 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ║ ╩ ║ ║\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╦═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 6 5 70 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ║ \n"
|
||||
" ║ ║ ║\n"
|
||||
" ╠══╦═══╬═══╣\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╚══╩═══╩═══╝\n"))
|
||||
(list (srcloc #f 6 6 71 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══════╩═\n"))
|
||||
(list (srcloc #f 6 11 76 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══════\n"))
|
||||
(list (srcloc #f 6 9 74 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══════╩═══X\n"))
|
||||
(list (srcloc #f 6 13 78 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║\n"
|
||||
" ╚══════╩══X╝\n"))
|
||||
(list (srcloc #f 6 12 77 1)))
|
||||
|
||||
(check-equal? (get-err-locs
|
||||
'("#2d\n"
|
||||
" ╔══╦═══╦═══╗\n"
|
||||
" ║ ║ ║ ║\n"
|
||||
" ╠══╩═══╬═══╣\n"
|
||||
" ║ ║ ║ NOT WHITESPACE\n"
|
||||
" ╚══════╩═══╝\n"))
|
||||
(list (srcloc #f 5 19 69 1))))
|
||||
|
||||
(let ([lines (hash-map lines-table (λ (x y) x))])
|
||||
(unless (null? lines)
|
||||
(eprintf "no test case for errors on lines: ~s\n"
|
||||
(sort lines <))))
|
||||
|
||||
|
||||
(check-equal? (get-graph
|
||||
'(" ╔══╦══╦══╗\n"
|
||||
" ║ 1║ 2║ 3║\n"
|
||||
" ╠══╬══╩══╣\n"
|
||||
" ║ 4║ ║\n"
|
||||
" ╠══╣ 6 ║\n"
|
||||
" ║ 5║ ║\n"
|
||||
" ╚══╩═════╝\n"))
|
||||
(make-hash
|
||||
(list (cons (list 0 0) (set))
|
||||
(cons (list 0 1) (set))
|
||||
(cons (list 0 2) (set))
|
||||
(cons (list 1 0) (set))
|
||||
(cons (list 2 0) (set))
|
||||
|
||||
(cons (list 1 1) (set (list 1 2) (list 2 1)))
|
||||
(cons (list 2 1) (set (list 1 1) (list 2 2)))
|
||||
(cons (list 1 2) (set (list 1 1) (list 2 2)))
|
||||
(cons (list 2 2) (set (list 1 2) (list 2 1))))))
|
||||
|
||||
(check-equal? (get-graph
|
||||
'(" ╔══╦══╦══╗\n"
|
||||
" ║1 ║2 ║3 ║\n"
|
||||
" ╠══╬══╬══╣\n"
|
||||
" ║6 ║5 ║4 ║\n"
|
||||
" ╠══╬══╬══╣\n"
|
||||
" ║7 ║8 ║9 ║\n"
|
||||
" ╚══╩══╩══╝\n"))
|
||||
(make-hash
|
||||
(list (cons (list 0 0) (set))
|
||||
(cons (list 0 1) (set))
|
||||
(cons (list 0 2) (set))
|
||||
(cons (list 1 0) (set))
|
||||
(cons (list 1 1) (set))
|
||||
(cons (list 1 2) (set))
|
||||
(cons (list 2 0) (set))
|
||||
(cons (list 2 1) (set))
|
||||
(cons (list 2 2) (set)))))
|
||||
|
||||
(check-equal? (get-graph
|
||||
'(" ╔══╦══╦══╦══╗\n"
|
||||
" ║1 ║2 ║3 ║4 ║\n"
|
||||
" ╠══╬══╩══╩══╣\n"
|
||||
" ║6 ║5 ║\n"
|
||||
" ╠══╣ ╔══╗ ║\n"
|
||||
" ║7 ║ ║10║ ║\n"
|
||||
" ╠══╣ ╚══╝ ║\n"
|
||||
" ║7 ║ ║\n"
|
||||
" ╚══╩════════╝\n"))
|
||||
(make-hash
|
||||
(list (cons (list 0 0) (set))
|
||||
(cons (list 0 1) (set))
|
||||
(cons (list 0 2) (set))
|
||||
(cons (list 0 3) (set))
|
||||
|
||||
(cons (list 1 0) (set))
|
||||
(cons (list 1 1) (set (list 1 2) (list 2 1)))
|
||||
(cons (list 1 2) (set (list 1 1) (list 1 3)))
|
||||
(cons (list 1 3) (set (list 1 2) (list 2 3)))
|
||||
|
||||
(cons (list 2 0) (set))
|
||||
(cons (list 2 1) (set (list 1 1) (list 3 1)))
|
||||
(cons (list 2 2) (set))
|
||||
(cons (list 2 3) (set (list 1 3) (list 3 3)))
|
||||
|
||||
(cons (list 3 0) (set))
|
||||
(cons (list 3 1) (set (list 2 1) (list 3 2)))
|
||||
(cons (list 3 2) (set (list 3 1) (list 3 3)))
|
||||
(cons (list 3 3) (set (list 3 2) (list 2 3))))))
|
||||
|
||||
(check-equal? (get-all-lines '(" ╔══╦══╗\n"
|
||||
" ║1 ║ ║\r"
|
||||
" ╠══╬══╣\r\n"
|
||||
" ║2 ║ ║\r"
|
||||
" ╠══╬══╣\n"
|
||||
" ║3 ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
'#((" ╔══╦══╗\n" " ║1 ║ ║\r")
|
||||
(" ╠══╬══╣\r\n" " ║2 ║ ║\r")
|
||||
(" ╠══╬══╣\n" " ║3 ║ ║\n")))
|
||||
|
||||
(check-equal? (get-table-column-breaks '(" ╔══╦══╗\n"
|
||||
" ║1 ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║2 ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║3 ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
(list 2 2))
|
||||
(check-equal? (get-initial-space-count '(" ╔══╦══╗\n"
|
||||
" ║1 ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║2 ║ ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║3 ║ ║\n"
|
||||
" ╚══╩══╝\n"))
|
||||
2)
|
||||
|
||||
(check-equal? (close-cell-graph (make-hash) 2 2)
|
||||
(set (set (list 0 0))
|
||||
(set (list 0 1))
|
||||
(set (list 1 0))
|
||||
(set (list 1 1))))
|
||||
|
||||
(check-equal? (close-cell-graph (make-hash
|
||||
(list
|
||||
(cons (list 0 0) (set (list 0 1)))))
|
||||
2 2)
|
||||
(set (set (list 0 0) (list 0 1))
|
||||
(set (list 1 0))
|
||||
(set (list 1 1))))
|
||||
|
||||
|
||||
(check-equal? (close-cell-graph (make-hash
|
||||
(list
|
||||
(cons (list 0 0) (set (list 0 1)))
|
||||
(cons (list 0 1) (set (list 1 1)))))
|
||||
2 2)
|
||||
(set (set (list 0 0) (list 0 1) (list 1 1))
|
||||
(set (list 1 0))))
|
||||
(check-equal? (close-cell-graph (make-hash
|
||||
(list
|
||||
(cons (list 0 0) (set (list 0 1)))
|
||||
(cons (list 0 1) (set (list 1 1)))
|
||||
(cons (list 1 1) (set (list 1 0)))))
|
||||
2 2)
|
||||
(set (set (list 0 0) (list 0 1) (list 1 1) (list 1 0))))
|
||||
|
||||
(check-true (compare/xy (list 0 0) (list 1 1)))
|
||||
(check-false (compare/xy (list 1 1) (list 0 0)))
|
||||
(check-true (compare/xy (list 1 0) (list 1 1)))
|
||||
(check-false (compare/xy (list 1 1) (list 1 0)))
|
||||
(check-false (compare/xy (list 1 0) (list 1 0)))
|
||||
|
||||
(check-equal? (smallest-representative (set (list 0 0) (list 1 0) (list 0 1) (list 1 1)))
|
||||
(list 0 0))
|
||||
(check-equal? (smallest-representative (set (list 1 1) (list 0 1) (list 1 0) (list 0 0)))
|
||||
(list 0 0))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " "))
|
||||
(fill-scratch-string (set '(0 0))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n 12 \n \n \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " "))
|
||||
(fill-scratch-string (set '(1 0))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n 34 \n \n \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " "))
|
||||
(fill-scratch-string (set '(0 1))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n \n \n 56 \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " "))
|
||||
(fill-scratch-string (set '(1 1))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n \n \n 78 \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " \n 34 \n \n \n"))
|
||||
(fill-scratch-string (set '(1 0) '(1 1))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╣56║\n" "║78║90║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n 34 \n 56 \n 90 \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " \n 34 \n \n \n"))
|
||||
(fill-scratch-string (set '(0 1) '(1 1))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╩══╣\n" "║56789║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n \n \n 56789 \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " \n 34 \n \n \n"))
|
||||
(fill-scratch-string (set '(0 1) '(1 0) '(1 1))
|
||||
#(("╔══╦══╗\n" "║12║34║\n") ("╠══╝56║\n" "║7890A║\n"))
|
||||
scratch
|
||||
'(2 2)
|
||||
0)
|
||||
(check-equal? scratch
|
||||
" \n 34 \n 56 \n 7890A \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (string-copy " "))
|
||||
(fill-scratch-string (set '(0 0))
|
||||
#(("╔═════╗\n" "║12345║\n" "║67890║\n" "║ABCDE║\n"))
|
||||
scratch
|
||||
'(5)
|
||||
0)
|
||||
|
||||
(check-equal? scratch
|
||||
" \n 12345 \n 67890 \n ABCDE \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (make-string 66 #\space))
|
||||
(fill-scratch-string (set '(1 2) '(1 1) '(2 2) '(2 1))
|
||||
#(("╔══╦══╦══╗\n" "║12║34║56║\n")
|
||||
("╠══╬══╩══╣\n" "║78║90ABC║\n")
|
||||
("╠══╣DEFGH║\n" "║IJ║KLMNO║\n"))
|
||||
scratch
|
||||
'(2 2 2)
|
||||
0)
|
||||
|
||||
(check-equal? scratch
|
||||
" \n \n \n 90ABC \n DEFGH \n KLMNO \n"))
|
||||
|
||||
(let ()
|
||||
(define scratch (make-string 120 #\space))
|
||||
(fill-scratch-string
|
||||
(set '(1 2) '(1 3) '(2 3))
|
||||
#(("╔═╦════╦═════╗\n" "║1║2345║67890║\n")
|
||||
("╠═╬════╩═════╣\n" "║a║bcdefghijk║\n")
|
||||
("╠═╬════╗lmnop║\n" "║q║rstu║vwxyz║\n")
|
||||
("╠═╣ABCD╚═════╣\n" "║E║FGHIJKLMNO║\n"))
|
||||
scratch
|
||||
'(1 4 5)
|
||||
0)
|
||||
(check-equal? (string-append
|
||||
" \n"
|
||||
" \n"
|
||||
" \n"
|
||||
" \n"
|
||||
" \n"
|
||||
" rstu \n"
|
||||
" ABCD \n"
|
||||
" FGHIJKLMNO \n")
|
||||
scratch))
|
||||
|
||||
(let ()
|
||||
(define scratch (make-string 495 #\space))
|
||||
(fill-scratch-string
|
||||
(set '(1 2) '(1 3) '(1 4) '(2 3) '(2 4) '(3 4))
|
||||
#(("╔════════╦════╦═════╦════════╦═════════════╗\n"
|
||||
"║ ║'Int║'Real║'Complex║ `(-> ,c ,d) ║\n")
|
||||
("╠════════╬════╩═════╩════════╬═════════════╣\n"
|
||||
"║'Int ║ ║ ║\n")
|
||||
("╠════════╬════╗ #t ║ ║\n"
|
||||
"║'Real ║ ║ ║ #f ║\n")
|
||||
("╠════════╣ ╚═════╗ ║ ║\n"
|
||||
"║'Complex║ ║ ║ ║\n")
|
||||
("╠════════╣ ╚════════╬═════════════╣\n"
|
||||
"║`(-> ,a ║ #f ║(and (≤ c a) ║\n"
|
||||
"║ ,b)║ ║ (≤ b d))║\n"))
|
||||
scratch
|
||||
'(8 4 5 8 13)
|
||||
0)
|
||||
;; just make sure there are no border characters in there.
|
||||
(check-regexp-match #rx"^[\n#f ]*$" scratch))
|
||||
|
||||
(let ()
|
||||
(define str (make-string 84 #\space))
|
||||
(fill-scratch-string (set '(1 2) '(1 1) '(2 1))
|
||||
'#(("╔═══╦═══╦═══╗\n"
|
||||
"║ ║ a ║ b ║\n")
|
||||
("╠═══╬═══╩═══╣\n"
|
||||
"║ c ║ 1 ║\n")
|
||||
("╠═══╣ ╔═══╣\n"
|
||||
"║ d ║ ║ 2 ║\n"))
|
||||
str
|
||||
'(3 3 3)
|
||||
0)
|
||||
(check-equal? str
|
||||
" \n \n \n 1 \n \n \n"))
|
||||
|
||||
(let ()
|
||||
(define sp (open-input-string
|
||||
(string-append "#(#2d\n"
|
||||
" ╔══╦══╗\n"
|
||||
" ║1 ║2 ║\n"
|
||||
" ╠══╬══╣\n"
|
||||
" ║4 ║3 ║\n"
|
||||
" ╚══╩══╝)1\n")))
|
||||
(parameterize ([current-readtable (make-2d-readtable)])
|
||||
(check-true (vector? (read sp)))
|
||||
(check-equal? (read sp) 1)))
|
||||
77
collects/unstable/2d/cond.rkt
Normal file
77
collects/unstable/2d/cond.rkt
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
#lang racket
|
||||
|
||||
(provide 2dcond)
|
||||
(define-syntax (2dcond stx)
|
||||
(syntax-case stx ()
|
||||
[(_ widths heights
|
||||
[(cell ...) rhs ...] ...)
|
||||
(let ()
|
||||
|
||||
;; coord-to-content : hash[(list num num) -o> (listof syntax)]
|
||||
(define coord-to-content (make-hash))
|
||||
(define let-bindings '())
|
||||
|
||||
;; build up the coord-to-content mapping
|
||||
;; side-effect: record need for let bindings to
|
||||
;; cover the the situation where multiple cells
|
||||
;; are joined together
|
||||
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
|
||||
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
|
||||
(define cells (syntax->datum cells-stx))
|
||||
|
||||
(cond
|
||||
[(member (list 0 0) cells)
|
||||
(unless (null? (syntax-e rhses))
|
||||
(raise-syntax-error '2dcond
|
||||
"cell at 0,0 must be empty"
|
||||
stx))]
|
||||
[else
|
||||
(when (null? (syntax-e rhses))
|
||||
(raise-syntax-error '2dcond
|
||||
(format "cell at ~a,~a must not be empty"
|
||||
(list-ref (car cells) 0)
|
||||
(list-ref (car cells) 1))
|
||||
stx))])
|
||||
|
||||
(cond
|
||||
[(member (list 0 0) cells) (void)]
|
||||
[(and
|
||||
;; only one cell:
|
||||
(null? (cdr cells))
|
||||
;; not in the left-edge (questions)
|
||||
(not (= 0 (car (car cells)))))
|
||||
;; then we don't need a let binding
|
||||
(hash-set! coord-to-content
|
||||
(car cells)
|
||||
(syntax->list rhses))]
|
||||
[else
|
||||
(for ([cell (in-list cells)])
|
||||
(define x (list-ref cell 0))
|
||||
(define y (list-ref cell 1))
|
||||
(with-syntax ([(id) (generate-temporaries (list (format "2dcond~a-~a" x y)))]
|
||||
[(rhs ...) rhses])
|
||||
(set! let-bindings (cons #`[id (λ () rhs ...)]
|
||||
let-bindings))
|
||||
(hash-set! coord-to-content cell (list #'(id)))))]))
|
||||
|
||||
(define num-of-cols (length (syntax->list #'widths)))
|
||||
(define num-of-rows (length (syntax->list #'heights)))
|
||||
#`(let #,let-bindings
|
||||
#,(for/fold ([else-branch #'(2dcond-runtime-error #f)])
|
||||
([x-flip (in-range 1 num-of-cols)])
|
||||
(define x (- num-of-cols x-flip))
|
||||
#`(if (let () #,@(hash-ref coord-to-content (list x 0)))
|
||||
(cond
|
||||
#,@(for/list ([y (in-range 1 num-of-rows)])
|
||||
#`[(let () #,@(hash-ref coord-to-content (list 0 y)))
|
||||
#,@(hash-ref coord-to-content (list x y))])
|
||||
[else (2dcond-runtime-error #,x)])
|
||||
#,else-branch))))]))
|
||||
|
||||
(define (2dcond-runtime-error dir)
|
||||
(define str
|
||||
(if dir
|
||||
(format "all of the y-direction questions were false (x coordinate ~a was true)"
|
||||
dir)
|
||||
"all of the x-direction questions were false"))
|
||||
(error '2dcond str))
|
||||
37
collects/unstable/2d/lang/reader.rkt
Normal file
37
collects/unstable/2d/lang/reader.rkt
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#lang racket/base
|
||||
(require syntax/module-reader
|
||||
(only-in "../private/readtable.rkt" make-2d-readtable))
|
||||
|
||||
(provide (rename-out [2d-read read]
|
||||
[2d-read-syntax read-syntax]
|
||||
[2d-get-info get-info]))
|
||||
|
||||
(define 2d-readtable (make-2d-readtable))
|
||||
|
||||
(define (wrap-reader p)
|
||||
(lambda args
|
||||
(parameterize ([current-readtable 2d-readtable])
|
||||
(apply p args))))
|
||||
|
||||
(define-values (2d-read 2d-read-syntax 2d-get-info)
|
||||
(make-meta-reader
|
||||
'2d
|
||||
"language path"
|
||||
(lambda (bstr)
|
||||
(let* ([str (bytes->string/latin-1 bstr)]
|
||||
[sym (string->symbol str)])
|
||||
(and (module-path? sym)
|
||||
(vector
|
||||
;; try submod first:
|
||||
`(submod ,sym reader)
|
||||
;; fall back to /lang/reader:
|
||||
(string->symbol (string-append str "/lang/reader"))))))
|
||||
wrap-reader
|
||||
wrap-reader
|
||||
(lambda (proc)
|
||||
(lambda (key defval)
|
||||
(case key
|
||||
#;
|
||||
[(color-lexer)
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
|
||||
[else (if proc (proc key defval) defval)])))))
|
||||
73
collects/unstable/2d/match.rkt
Normal file
73
collects/unstable/2d/match.rkt
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/match)
|
||||
|
||||
(provide 2dmatch)
|
||||
(define-syntax (2dmatch stx)
|
||||
(syntax-case stx ()
|
||||
[(_ widths heights
|
||||
[(cell ...) rhs ...] ...)
|
||||
(let ()
|
||||
|
||||
;; coord-to-content : hash[(list num num) -o> (listof syntax)]
|
||||
(define coord-to-content (make-hash))
|
||||
(define let-bindings '())
|
||||
|
||||
(define main-args #f)
|
||||
|
||||
;; build up the coord-to-content mapping
|
||||
;; side-effect: record need for let bindings to
|
||||
;; cover the the situation where multiple cells
|
||||
;; are joined together
|
||||
;; (this code is similar to that in cond.rkt, but
|
||||
;; my attempt at abstracting between them was unsuccessful)
|
||||
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
|
||||
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
|
||||
(define cells (syntax->datum cells-stx))
|
||||
(define on-boundary? (ormap (λ (lst) (or (= 0 (list-ref lst 0))
|
||||
(= 0 (list-ref lst 1))))
|
||||
cells))
|
||||
(define rhses-lst (syntax->list rhses))
|
||||
(cond
|
||||
[(member (list 0 0) cells)
|
||||
(unless (and rhses-lst (= 2 (length rhses-lst)))
|
||||
(raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions"))
|
||||
(set! main-args rhses)]
|
||||
[on-boundary?
|
||||
(unless (and rhses-lst (= 1 (length rhses-lst)))
|
||||
(raise-syntax-error '2dmatch
|
||||
(format "cell at ~a,~a must contain exactly one match pattern")
|
||||
stx))
|
||||
(hash-set! coord-to-content (car cells) (car (syntax->list rhses)))]
|
||||
[else
|
||||
(when (null? (syntax-e rhses))
|
||||
(raise-syntax-error '2dmatch
|
||||
(format "cell at ~a,~a should not be empty"
|
||||
(list-ref (car cells) 0)
|
||||
(list-ref (car cells) 1))
|
||||
stx))
|
||||
(cond
|
||||
[(null? (cdr cells)) ;; only one cell:
|
||||
;; => we don't need a let binding
|
||||
(hash-set! coord-to-content
|
||||
(car cells)
|
||||
(syntax->list rhses))]
|
||||
[else
|
||||
(for ([cell (in-list cells)])
|
||||
(define x (list-ref cell 0))
|
||||
(define y (list-ref cell 1))
|
||||
(with-syntax ([(id) (generate-temporaries (list (format "2dmatch~a-~a" x y)))]
|
||||
[(rhs ...) rhses])
|
||||
(set! let-bindings (cons #`[id (λ () rhs ...)]
|
||||
let-bindings))
|
||||
(hash-set! coord-to-content cell (list #'(id)))))])]))
|
||||
|
||||
(define num-of-cols (length (syntax->list #'widths)))
|
||||
(define num-of-rows (length (syntax->list #'heights)))
|
||||
#`(let #,let-bindings
|
||||
(match* #,main-args
|
||||
#,@(for*/list ([x (in-range 1 num-of-cols)]
|
||||
[y (in-range 1 num-of-rows)])
|
||||
#`[(#,(hash-ref coord-to-content (list x 0))
|
||||
#,(hash-ref coord-to-content (list 0 y)))
|
||||
(let () #,@(hash-ref coord-to-content (list x y)))]))))]))
|
||||
690
collects/unstable/2d/private/readtable.rkt
Normal file
690
collects/unstable/2d/private/readtable.rkt
Normal file
|
|
@ -0,0 +1,690 @@
|
|||
#lang racket/base
|
||||
#|
|
||||
|
||||
ideas:
|
||||
- 2dcond
|
||||
- 2dmatch
|
||||
- literal tables in scribble layout?
|
||||
- something for graphics?
|
||||
|
||||
example uses:
|
||||
- unifier
|
||||
- subtyping relation
|
||||
|
||||
|#
|
||||
|
||||
(require racket/port
|
||||
syntax/readerr
|
||||
racket/match
|
||||
racket/set
|
||||
;syntax/rect
|
||||
framework/private/dir-chars
|
||||
(for-syntax racket/base
|
||||
racket/list))
|
||||
|
||||
|
||||
(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)))
|
||||
|
||||
(define (make-2d-readtable)
|
||||
(define previous-readtable (current-readtable))
|
||||
(make-readtable
|
||||
#f
|
||||
#\2
|
||||
'dispatch-macro
|
||||
(case-lambda
|
||||
[(char port)
|
||||
(define-values (line col pos) (port-next-location port))
|
||||
(dispatch-proc char port #f line col pos read/recursive previous-readtable)]
|
||||
[(char port source _line _col _pos)
|
||||
(dispatch-proc char port source _line _col _pos
|
||||
(λ (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
|
||||
[(equal? next-char #\d)
|
||||
(define chars-read 2) ;; account for the # and the 2
|
||||
(define (rc)
|
||||
(set! chars-read (+ chars-read 1))
|
||||
(read-char port))
|
||||
(rc) ;; get the #\d
|
||||
(define kwd-chars
|
||||
(let loop ()
|
||||
(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)
|
||||
(list (srcloc source
|
||||
_line _col _pos
|
||||
(+ _pos chars-read)))))]
|
||||
[(equal? c #\newline) '()]
|
||||
[(equal? c #\return)
|
||||
(when (equal? #\newline (peek-char port))
|
||||
(rc))
|
||||
'()]
|
||||
[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)
|
||||
(parse-2dcond port source _line _col _pos chars-read))
|
||||
(define lhses (close-cell-graph edges (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)))
|
||||
#\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)]))]
|
||||
[else
|
||||
(/recursive
|
||||
(input-port-append #f (open-input-string "#2") port)
|
||||
#f
|
||||
previous-readtable)]))
|
||||
|
||||
(define (read-subparts source scratch-port
|
||||
initial-space-count table-column-breaks heights lhs
|
||||
previous-readtable /recursive)
|
||||
(with-handlers (#;
|
||||
[exn:fail:read?
|
||||
(λ (exn)
|
||||
(define constructor
|
||||
(cond
|
||||
[(exn:fail:read:eof? exn) exn:fail:read:eof/rects]
|
||||
[(exn:fail:read:non-char? exn) exn:fail:read:non-char/rects]
|
||||
[else exn:fail:read/rects]))
|
||||
(raise
|
||||
(constructor (exn-message exn)
|
||||
(exn-continuation-marks exn)
|
||||
(exn:fail:read-srclocs exn)
|
||||
(build-rectangles
|
||||
source
|
||||
initial-space-count table-column-breaks heights lhs))))])
|
||||
(let loop ()
|
||||
(define o (/recursive scratch-port #f previous-readtable))
|
||||
(cond
|
||||
[(eof-object? o) '()]
|
||||
[else (cons o (loop))]))))
|
||||
|
||||
#;
|
||||
(define (build-rectangles source table-column-breaks heights set-of-indicies)
|
||||
(for/list ([pr (in-set set-of-indicies)])
|
||||
(define x (list-ref pr 0))
|
||||
(define y (list-ref pr 1))
|
||||
(srcloc-rect source
|
||||
?-start-position
|
||||
(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)))
|
||||
|
||||
63
collects/unstable/scribblings/2d.scrbl
Normal file
63
collects/unstable/scribblings/2d.scrbl
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/base
|
||||
scribble/manual
|
||||
"utils.rkt"
|
||||
(for-label ;unstable/2d/cond
|
||||
;unstable/2d/match
|
||||
racket/file
|
||||
racket/contract
|
||||
racket/base))
|
||||
|
||||
@title[#:tag "2d"]{2D Cond and Match}
|
||||
|
||||
@defmodulelang[unstable/2d]{The @racketmodname[unstable/2d] language installs
|
||||
@litchar{#2d} reader support in the readtable, and then chains to the reader of
|
||||
another language that is specified immediately after
|
||||
@racketmodname[unstable/2d].}
|
||||
|
||||
The @litchar{#2d} syntax extension adds the ability use
|
||||
two dimensional grid syntax. That is, you can drawn an ASCII-art
|
||||
grid and then treat that as a conditional expression. For example,
|
||||
here is a simple equality function that operates on pairs and
|
||||
numbers:
|
||||
@codeblock{
|
||||
#lang unstable/2d racket
|
||||
|
||||
(define (same? a b)
|
||||
#2dcond
|
||||
╔═════════════╦═══════════════════════╦═════════════╗
|
||||
║ ║ (pair? a) ║ (number? a) ║
|
||||
╠═════════════╬═══════════════════════╬═════════════╣
|
||||
║ (pair? b) ║ (and (same? (car a) ║ #f ║
|
||||
║ ║ (car b)) ║ ║
|
||||
║ ║ (same? (cdr a) ║ ║
|
||||
║ ║ (cdr b))) ║ ║
|
||||
╠═════════════╬═══════════════════════╬═════════════╣
|
||||
║ (number? b) ║ #f ║ (= a b) ║
|
||||
╚═════════════╩═══════════════════════╩═════════════╝)
|
||||
}
|
||||
|
||||
This notation works in two stages: reading, and parsing (just as in
|
||||
Racket in general). The reading stage converts anything that begins
|
||||
with @litchar{#2d} into a parenthesized expression (possibly signaling
|
||||
errors if the @litchar{═} and @litchar{║} and @litchar{╬}
|
||||
characters do not line up in the right places).
|
||||
|
||||
Since the first line contains @litchar{#2dcond}, the reader will
|
||||
produce a sequence whose first position is the identifier @racket[2dcond].
|
||||
|
||||
That macro will take over and then expand into ordinary conditional
|
||||
expressions, in this case figuring out whether or not the inputs
|
||||
are pairs or numbers and selecting the appropriate cell.
|
||||
|
||||
@section{2D Cond}
|
||||
|
||||
@defmodule[unstable/2d/cond]
|
||||
|
||||
@defform[(2dcond . stuff)]{}
|
||||
|
||||
@section{2D Match}
|
||||
|
||||
@defmodule[unstable/2d/match]
|
||||
|
||||
@defform[(2dmatch . stuff)]{}
|
||||
|
|
@ -104,6 +104,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["custom-write.scrbl"] ;; Struct Printing
|
||||
@include-section["syntax.scrbl"]
|
||||
@include-section["../temp-c/scribblings/temp-c.scrbl"]
|
||||
@include-section["2d.scrbl"]
|
||||
|
||||
@;{--------}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user