ASCII art diagram converter: Difference between revisions
{{header|Racket}} implementation added
m (→{{header|Racket}}: checkpoint) |
({{header|Racket}} implementation added) |
||
Line 351:
* <b><code>test-ascci-art-reader.rkt</code>:</b> gives it all a rigourousish going over
Note that this is in the <code>racket/base</code> language so it doesn't overburden the modules that import it, especially since they're at the suntax phase.
<lang racket>#lang racket/base
(require (only-in racket/list drop-right)
(only-in racket/string string-trim))
;; reads ascii art from a string or input-port
;; returns:
;; list of (word-number highest-bit lowest-bit name-symbol)
;; bits per word
(define (ascii-art->struct art)
(define art-inport
(cond
[(string? art) (open-input-string art)]
[(input-port? art) art]
[else (raise-argument-error 'ascii-art->struct
"(or/c string? input-port?)"
art)]))
(define lines
(for/list ((l (in-port (lambda (p)
(define pk (peek-char p))
(case pk ((#\+ #\|) (read-line p))
(else eof)))
art-inport)))
l))
(when (null? lines)
(error 'ascii-art->struct "no lines"))
(define bit-re #px"[|+]([^|+]*)")
(define cell-re #px"[|]([^|]*)")
(define bit-boundaries (regexp-match-positions* bit-re (car lines)))
(define bits/word (sub1 (length bit-boundaries)))
(unless (zero? (modulo bits/word 8))
(error 'ascii-art->struct "diagram is not a multiple of 8 bits wide"))
(define-values (pos->bit-start# pos->bit-end#)
(for/fold ((s# (hash)) (e# (hash)))
((box (in-range bits/word))
(boundary (in-list bit-boundaries)))
(define bit (- bits/word box 1))
(values (hash-set s# (car boundary) bit)
(hash-set e# (cdr boundary) bit))))
(define fields
(apply append
(for/list ((line-number (in-naturals))
(line (in-list lines))
#:when (odd? line-number))
(define word (quotient line-number 2))
(define cell-positions (regexp-match-positions* cell-re line))
(define cell-contents (regexp-match* cell-re line))
(for/list ((cp (in-list (drop-right cell-positions 1)))
(cnt (in-list cell-contents)))
(define cell-start-bit (hash-ref pos->bit-start# (car cp)))
(define cell-end-bit (hash-ref pos->bit-end# (cdr cp)))
(list word cell-start-bit cell-end-bit (string->symbol (string-trim (substring cnt 1))))))))
(values fields bits/word))</lang>
<b><code>ascii-art-reader.rkt</code></b>
<lang racket>#lang racket
(require (for-syntax "ascii-art-parser.rkt"))
(require (for-syntax racket/syntax))
(provide (all-defined-out))
(define-syntax (define-ascii-art-structure stx)
(syntax-case stx ()
[(_ id art)
(let*-values (((all-fields bits/word) (ascii-art->struct (syntax-e #'art))))
(with-syntax
((bytes->id (format-id stx "bytes->~a" #'id))
(id->bytes (format-id stx "~a->bytes" #'id))
(word-size (add1 (car (for/last ((f all-fields)) f))))
(fld-ids (map cadddr all-fields))
(fld-setters
(cons
#'id
(for/list ((fld (in-list all-fields)))
(let* ((bytes/word (quotient bits/word 8))
(start-byte (let ((word-no (car fld))) (* word-no bytes/word))))
`(bitwise-bit-field (integer-bytes->integer bs
#f
(system-big-endian?)
,start-byte
,(+ start-byte bytes/word))
,(caddr fld)
,(add1 (cadr fld)))))))
(set-fields-bits
(list*
'begin
(for/list ((fld (in-list all-fields)))
(define val (cadddr fld))
(define start-bit (cadr fld))
(define end-bit (caddr fld))
(define start-byte (let ((word-no (car fld))) (* word-no (quotient bits/word 8))))
(define fld-bit-width (- start-bit end-bit -1))
(define aligned?/width (and (= end-bit 0)
(= (modulo start-bit 8) 7)
(quotient fld-bit-width 8)))
(case aligned?/width
[(2 4)
`(integer->integer-bytes ,val
,aligned?/width
#f
(system-big-endian?)
rv
,start-byte)]
[else
(define the-byte (+ start-byte (quotient end-bit 8)))
`(bytes-set! rv
,the-byte
(bitwise-ior (arithmetic-shift (bitwise-bit-field ,val 0 ,fld-bit-width)
,(modulo end-bit 8))
(bytes-ref rv ,the-byte)))])))))
#`(begin
(struct id fld-ids #:mutable)
(define (bytes->id bs)
fld-setters)
(define (id->bytes art-in)
(match-define (id #,@#'fld-ids) art-in)
(define rv (make-bytes (* word-size #,(quotient bits/word 8))))
set-fields-bits
rv))))]))</lang>
<b><code>test-ascii-art-reader.rkt</code></b>
<lang racket>#lang racket
(require "ascii-art-reader.rkt")
(require "ascii-art-parser.rkt")
(require tests/eli-tester)
(define rfc-1035-header-art
#<<EOS
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ID |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR| Opcode |AA|TC|RD|RA| Z | RCODE |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| QDCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ANCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| NSCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ARCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
EOS
)
(define-values (rslt rslt-b/w) (ascii-art->struct rfc-1035-header-art))
(test
rslt-b/w => 16
rslt =>
'((0 15 0 ID)
(1 15 15 QR)
(1 14 11 Opcode)
(1 10 10 AA)
(1 9 9 TC)
(1 8 8 RD)
(1 7 7 RA)
(1 6 4 Z)
(1 3 0 RCODE)
(2 15 0 QDCOUNT)
(3 15 0 ANCOUNT)
(4 15 0 NSCOUNT)
(5 15 0 ARCOUNT)))
(define-ascii-art-structure rfc-1035-header #<<EOS
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ID |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR| Opcode |AA|TC|RD|RA| Z | RCODE |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| QDCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ANCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| NSCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
| ARCOUNT |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
EOS
)
(define h-bytes
(bytes-append
(integer->integer-bytes #x1234 2 #f)
(integer->integer-bytes #x5678 2 #f)
(integer->integer-bytes #x9abc 2 #f)
(integer->integer-bytes #xdef0 2 #f)
(integer->integer-bytes #xfedc 2 #f)
(integer->integer-bytes #xba98 2 #f)))
(define h-bytes~
(bytes-append
(integer->integer-bytes #x1234 2 #f (not (system-big-endian?)))
(integer->integer-bytes #x5678 2 #f (not (system-big-endian?)))
(integer->integer-bytes #x9abc 2 #f (not (system-big-endian?)))
(integer->integer-bytes #xdef0 2 #f (not (system-big-endian?)))
(integer->integer-bytes #xfedc 2 #f (not (system-big-endian?)))
(integer->integer-bytes #xba98 2 #f (not (system-big-endian?)))))
(define h (bytes->rfc-1035-header h-bytes))
(define bytes-h (rfc-1035-header->bytes h))
(define h~ (bytes->rfc-1035-header h-bytes~))
(define bytes-h~ (rfc-1035-header->bytes h~))
(test
(rfc-1035-header-ID h) => #x1234
(rfc-1035-header-ARCOUNT h) => #xBA98
(rfc-1035-header-RCODE h) => 8
(rfc-1035-header-ID h~) => #x3412
(rfc-1035-header-ARCOUNT h~) => #x98BA
(rfc-1035-header-RCODE h~) => 6
h-bytes => bytes-h
h-bytes~ => bytes-h~)
(set-rfc-1035-header-RA! h 0)
(set-rfc-1035-header-Z! h 7)
(test
(rfc-1035-header-Z (bytes->rfc-1035-header (rfc-1035-header->bytes h))) => 7
(rfc-1035-header-RA (bytes->rfc-1035-header (rfc-1035-header->bytes h))) => 0)
(set-rfc-1035-header-Z! h 15) ;; naughty -- might splat RA
(test
(rfc-1035-header-Z (bytes->rfc-1035-header (rfc-1035-header->bytes h))) => 7
(rfc-1035-header-RA (bytes->rfc-1035-header (rfc-1035-header->bytes h))) => 0)</lang>
{{out}}
| |||