765 lines
22 KiB
Scheme
765 lines
22 KiB
Scheme
;;
|
|
;; box-drawing.scm
|
|
;;
|
|
;; Unicode box drawing combiners.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit box-drawing))
|
|
|
|
(module
|
|
box-drawing
|
|
(
|
|
combine-line-cells
|
|
|
|
line-cell-somewhat-heavy?
|
|
|
|
line-cell->unicode-char
|
|
line-cell->utf8-string
|
|
|
|
line-cell->ascii-char
|
|
|
|
char->line-cell
|
|
|
|
combine-line-char
|
|
|
|
line-style-none
|
|
|
|
combine-line-style
|
|
|
|
line-cell-north
|
|
line-cell-east
|
|
line-cell-west
|
|
line-cell-south
|
|
|
|
spec->line-style
|
|
line-style-spec?
|
|
|
|
make-line-cell
|
|
make-straight-horizontal-line-cell
|
|
make-straight-vertical-line-cell
|
|
make-straight-horizontal-line-cell*
|
|
make-straight-vertical-line-cell*
|
|
|
|
line-cell-none
|
|
|
|
set-line-cell-north
|
|
set-line-cell-west
|
|
set-line-cell-east
|
|
set-line-cell-south
|
|
|
|
spec->horizontal-line-cell
|
|
spec->vertical-line-cell
|
|
|
|
spec->top-left-corner-line-cell
|
|
spec->top-right-corner-line-cell
|
|
spec->bottom-left-corner-line-cell
|
|
spec->bottom-right-corner-line-cell
|
|
|
|
extract-line-cell-top-left
|
|
extract-line-cell-top-right
|
|
extract-line-cell-bottom-left
|
|
extract-line-cell-bottom-right
|
|
|
|
box-drawing-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken bitwise)
|
|
util-utf8
|
|
racket-kwargs
|
|
testing)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Bit manipulators
|
|
|
|
(define-syntax define-bit-predicate
|
|
(syntax-rules ()
|
|
((_ name mask value)
|
|
(define (name bits)
|
|
(= (bitwise-and bits mask) value)))))
|
|
|
|
(define-syntax define-bit-setter
|
|
(syntax-rules ()
|
|
((_ name andmask ormask)
|
|
(define (name bits)
|
|
(bitwise-ior (bitwise-and bits andmask) ormask)))))
|
|
|
|
(define-syntax define-bit-combiner
|
|
(syntax-rules ()
|
|
((_ name mask)
|
|
(define (name a b)
|
|
(bitwise-ior
|
|
(bitwise-and a mask)
|
|
(bitwise-and b mask))))))
|
|
|
|
(define-syntax define-bit-accessor
|
|
(syntax-rules ()
|
|
((_ name shift mask)
|
|
(define (name bits)
|
|
(bitwise-and
|
|
(arithmetic-shift bits (- shift)) mask)))))
|
|
|
|
(define-syntax define-bit-accessor-setter
|
|
(syntax-rules ()
|
|
((_ name shift mask)
|
|
(define (name bits ormask)
|
|
(bitwise-ior (bitwise-and (bitwise-not (arithmetic-shift mask shift))
|
|
bits)
|
|
(arithmetic-shift (bitwise-and ormask mask)
|
|
shift))))))
|
|
|
|
(define-syntax define-inverted-bit-predicate
|
|
(syntax-rules ()
|
|
((_ name mask value)
|
|
(define (name bits)
|
|
(not (= (bitwise-and bits mask) 0))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Line thickness
|
|
;; * none
|
|
;; * light
|
|
;; * heavy
|
|
;; Bit indices: 10
|
|
;; ||_ lower bit: light thickness
|
|
;; |_ higher bit: heavy thickness
|
|
;; Values:
|
|
;; 00 - none
|
|
;; 01 - light
|
|
;; 10 - heavy
|
|
;; 11 - heavy
|
|
|
|
(define line-thickness-none 0)
|
|
(define line-thickness-light 1)
|
|
(define line-thickness-heavy 2)
|
|
|
|
(define-bit-predicate line-thickness-light? 3 1)
|
|
(define-bit-predicate line-thickness-heavy? 2 2)
|
|
(define-bit-predicate line-thickness-none? 3 0)
|
|
|
|
(define-bit-setter set-line-thickness-light 3 1)
|
|
(define-bit-setter set-line-thickness-heavy 3 2)
|
|
(define-bit-setter set-line-thickness-none 0 0)
|
|
|
|
(define-bit-combiner combine-line-thickness 3)
|
|
|
|
(define-inverted-bit-predicate line-thickness-some? 3 0)
|
|
|
|
(define (line-thickness-normalize thickness)
|
|
(if (line-thickness-heavy? thickness)
|
|
line-thickness-heavy
|
|
thickness))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Line type
|
|
;; * none
|
|
;; * dashed
|
|
;; * solid
|
|
;; Bit indices: 10
|
|
;; ||_ lower bit: dashed type
|
|
;; |_ higher bit: solid type
|
|
;; Values:
|
|
;; * 00 - none
|
|
;; * 01 - dashed
|
|
;; * 10 - solid
|
|
;; * 11 - solid
|
|
|
|
(define line-type-none 0)
|
|
(define line-type-dashed 1)
|
|
(define line-type-solid 2)
|
|
|
|
(define-bit-predicate line-type-dashed? 3 1)
|
|
(define-bit-predicate line-type-solid? 2 2)
|
|
(define-bit-predicate line-type-none? 3 0)
|
|
|
|
(define-bit-setter set-line-type-dashed 3 1)
|
|
(define-bit-setter set-line-type-solid 3 2)
|
|
(define-bit-setter set-line-type-none 0 0)
|
|
|
|
(define-bit-combiner combine-line-type 3)
|
|
|
|
(define-inverted-bit-predicate line-type-some? 3 0)
|
|
|
|
(define (line-type-normalize type)
|
|
(if (line-type-solid? type)
|
|
line-type-solid
|
|
type))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Line style
|
|
;; * thickness
|
|
;; * type
|
|
;; Double-bit indices: 10
|
|
;; ||_ lower nibble: thickness
|
|
;; |_ higher nibble: type
|
|
;; Bit indices: 3210
|
|
;; ||||_ light thickness
|
|
;; |||_ heavy thickness
|
|
;; ||_ dashed type
|
|
;; |_ solid type
|
|
|
|
(define line-style-none 0)
|
|
|
|
;; Creates line style from specific thickness and type
|
|
(define (make-line-style thickness type)
|
|
(bitwise-ior
|
|
(arithmetic-shift (bitwise-and type 3) 2)
|
|
(bitwise-and (bitwise-and thickness 3))))
|
|
|
|
(define-bit-accessor line-style-thickness 0 3)
|
|
(define-bit-accessor line-style-type 2 3)
|
|
|
|
(define-bit-predicate line-style-thickness-light? 3 1)
|
|
(define-bit-predicate line-style-thickness-heavy? 2 2)
|
|
(define-bit-predicate line-style-thickness-none? 3 0)
|
|
(define-bit-predicate line-style-type-dashed? 12 4)
|
|
(define-bit-predicate line-style-type-solid? 8 8)
|
|
(define-bit-predicate line-style-type-none? 12 0)
|
|
|
|
(define-bit-setter set-line-style-thickness-light 15 1)
|
|
(define-bit-setter set-line-style-thickness-heavy 15 2)
|
|
(define-bit-setter set-line-style-thickness-none 12 0)
|
|
(define-bit-setter set-line-style-type-dashed 15 4)
|
|
(define-bit-setter set-line-style-type-solid 15 8)
|
|
(define-bit-setter set-line-style-type-none 3 0)
|
|
|
|
(define-bit-combiner combine-line-style 15)
|
|
|
|
(define-inverted-bit-predicate line-style-thickness-some? 3 0)
|
|
(define-inverted-bit-predicate line-style-type-some? 12 0)
|
|
|
|
(define (line-style-some? style)
|
|
(and (line-style-thickness-some? style)
|
|
(line-style-type-some? style)))
|
|
|
|
(define (line-style-none? style)
|
|
(or (line-style-thickness-none? style)
|
|
(line-style-type-none? style)))
|
|
|
|
(define (line-style-normalize style)
|
|
(make-line-style
|
|
(line-thickness-normalize (line-style-thickness style))
|
|
(line-type-normalize (line-style-type style))))
|
|
|
|
(define (line-style-heavy? style)
|
|
(and (line-style-type-some? style)
|
|
(line-style-thickness-heavy? style)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Line cell
|
|
;; * north
|
|
;; * west
|
|
;; * east
|
|
;; * south
|
|
;; Nibble indices: 3210
|
|
;; ||||_ north style
|
|
;; |||_ west style
|
|
;; ||_ east style
|
|
;; |_ south style
|
|
;; Bit indices: fedcba9876543210
|
|
;; ||||||||||||||||_ north light thickness
|
|
;; |||||||||||||||_ north heavy thickness
|
|
;; ||||||||||||||_ north dashed type
|
|
;; |||||||||||||_ north solid type
|
|
;; ||||||||||||_ west light thickness
|
|
;; |||||||||||_ west heavy thickness
|
|
;; ||||||||||_ west dashed type
|
|
;; |||||||||_ west solid type
|
|
;; ||||||||_ east light thickness
|
|
;; |||||||_ east heavy thickness
|
|
;; ||||||_ east dashed type
|
|
;; |||||_ east solid type
|
|
;; ||||_ south light thickness
|
|
;; |||_ south heavy thickness
|
|
;; ||_ south dashed type
|
|
;; |_ south solid type
|
|
|
|
(define line-cell-none 0)
|
|
|
|
(define (make-line-cell n w e s)
|
|
(bitwise-ior
|
|
(bitwise-and n 15)
|
|
(arithmetic-shift (bitwise-and w 15) 4)
|
|
(arithmetic-shift (bitwise-and e 15) 8)
|
|
(arithmetic-shift (bitwise-and s 15) 12)))
|
|
|
|
(define-bit-accessor line-cell-north 0 15)
|
|
(define-bit-accessor line-cell-west 4 15)
|
|
(define-bit-accessor line-cell-east 8 15)
|
|
(define-bit-accessor line-cell-south 12 15)
|
|
|
|
(define-bit-accessor-setter set-line-cell-north 0 15)
|
|
(define-bit-accessor-setter set-line-cell-west 4 15)
|
|
(define-bit-accessor-setter set-line-cell-east 8 15)
|
|
(define-bit-accessor-setter set-line-cell-south 12 15)
|
|
|
|
(define-bit-combiner combine-line-cells 65535)
|
|
|
|
(define (make-straight-horizontal-line-cell thickness type)
|
|
(let ((style (make-line-style thickness type)))
|
|
(make-line-cell 0 style style 0)))
|
|
|
|
(define (make-straight-vertical-line-cell thickness type)
|
|
(let ((style (make-line-style thickness type)))
|
|
(make-line-cell style 0 0 style)))
|
|
|
|
(define (make-straight-horizontal-line-cell* style)
|
|
(make-line-cell 0 style style 0))
|
|
|
|
(define (make-straight-vertical-line-cell* style)
|
|
(make-line-cell style 0 0 style))
|
|
|
|
(define (make-cross-line-cell thickness type)
|
|
(let ((style (make-line-style thickness type)))
|
|
(make-line-cell style style style style)))
|
|
|
|
(define (line-cell-straight-horizontal? cell)
|
|
(and (line-style-none? (line-cell-north cell))
|
|
(line-style-none? (line-cell-south cell))
|
|
(line-style-some? (line-cell-west cell))
|
|
(line-style-some? (line-cell-east cell))
|
|
(= (line-style-normalize (line-cell-west cell))
|
|
(line-style-normalize (line-cell-east cell)))))
|
|
|
|
(define (line-cell-straight-vertical? cell)
|
|
(and (line-style-some? (line-cell-north cell))
|
|
(line-style-none? (line-cell-west cell))
|
|
(line-style-none? (line-cell-east cell))
|
|
(line-style-some? (line-cell-south cell))
|
|
(= (line-style-normalize (line-cell-north cell))
|
|
(line-style-normalize (line-cell-south cell)))))
|
|
|
|
(define (line-cell-mostly-horizontal? cell)
|
|
(and (line-style-none? (line-cell-north cell))
|
|
(line-style-none? (line-cell-south cell))
|
|
(line-style-some? (line-cell-west cell))
|
|
(line-style-some? (line-cell-east cell))))
|
|
|
|
(define (line-cell-mostly-vertical? cell)
|
|
(and (line-style-some? (line-cell-north cell))
|
|
(line-style-none? (line-cell-west cell))
|
|
(line-style-none? (line-cell-east cell))
|
|
(line-style-some? (line-cell-south cell))))
|
|
|
|
(define (line-cell-none? cell)
|
|
(and (line-style-none? (line-cell-north cell))
|
|
(line-style-none? (line-cell-west cell))
|
|
(line-style-none? (line-cell-east cell))
|
|
(line-style-none? (line-cell-south cell))))
|
|
|
|
(define (line-cell-somewhat-heavy? cell)
|
|
(or (line-style-heavy? (line-cell-north cell))
|
|
(line-style-heavy? (line-cell-west cell))
|
|
(line-style-heavy? (line-cell-east cell))
|
|
(line-style-heavy? (line-cell-south cell))))
|
|
|
|
(define (line-cell-straight-horizontal-type cell)
|
|
(line-style-type
|
|
(line-cell-west cell)))
|
|
|
|
(define (line-cell-straight-vertical-type cell)
|
|
(line-style-type
|
|
(line-cell-north cell)))
|
|
|
|
(define (line-cell-straight-horizontal-dashed? cell)
|
|
(and (line-cell-straight-horizontal? cell)
|
|
(line-type-dashed?
|
|
(line-cell-straight-horizontal-type cell))))
|
|
|
|
(define (line-cell-straight-vertical-dashed? cell)
|
|
(and (line-cell-straight-vertical? cell)
|
|
(line-type-dashed?
|
|
(line-cell-straight-vertical-type cell))))
|
|
|
|
(define (line-cell-straight-horizontal-thickness cell)
|
|
(line-style-thickness
|
|
(line-cell-west cell)))
|
|
|
|
(define (line-cell-straight-vertical-thickness cell)
|
|
(line-style-thickness
|
|
(line-cell-north cell)))
|
|
|
|
(define (line-cell-junction-compress cell)
|
|
(let ((n (line-thickness-normalize (line-style-thickness (line-cell-north cell))))
|
|
(w (line-thickness-normalize (line-style-thickness (line-cell-west cell))))
|
|
(e (line-thickness-normalize (line-style-thickness (line-cell-east cell))))
|
|
(s (line-thickness-normalize (line-style-thickness (line-cell-south cell)))))
|
|
(+ n
|
|
(* w 3)
|
|
(* e 9)
|
|
(* s 27))))
|
|
|
|
(define line-cell-char-junctions
|
|
(vector ;; SEWN (base-3 representation)
|
|
#\space ;; 0000
|
|
#\x2575 ;; 0001
|
|
#\x2579 ;; 0002
|
|
#\x2574 ;; 0010
|
|
#\x2518 ;; 0011
|
|
#\x251a ;; 0012
|
|
#\x2578 ;; 0020
|
|
#\x2519 ;; 0021
|
|
#\x251b ;; 0022
|
|
|
|
#\x2576 ;; 0100
|
|
#\x2514 ;; 0101
|
|
#\x2516 ;; 0102
|
|
#\x2500 ;; 0110
|
|
#\x2534 ;; 0111
|
|
#\x2538 ;; 0112
|
|
#\x257e ;; 0120
|
|
#\x2535 ;; 0121
|
|
#\x2539 ;; 0122
|
|
|
|
#\x257a ;; 0200
|
|
#\x2515 ;; 0201
|
|
#\x2517 ;; 0202
|
|
#\x257c ;; 0210
|
|
#\x2536 ;; 0211
|
|
#\x253a ;; 0212
|
|
#\x2501 ;; 0220
|
|
#\x2537 ;; 0221
|
|
#\x253b ;; 0222
|
|
|
|
#\x2577 ;; 1000
|
|
#\x2502 ;; 1001
|
|
#\x257f ;; 1002
|
|
#\x2510 ;; 1010
|
|
#\x2524 ;; 1011
|
|
#\x2526 ;; 1012
|
|
#\x2511 ;; 1020
|
|
#\x2525 ;; 1021
|
|
#\x2529 ;; 1022
|
|
|
|
#\x250c ;; 1100
|
|
#\x251c ;; 1101
|
|
#\x251e ;; 1102
|
|
#\x252c ;; 1110
|
|
#\x253c ;; 1111
|
|
#\x2540 ;; 1112
|
|
#\x252d ;; 1120
|
|
#\x253d ;; 1121
|
|
#\x2543 ;; 1122
|
|
|
|
#\x250d ;; 1200
|
|
#\x251d ;; 1201
|
|
#\x2521 ;; 1202
|
|
#\x252e ;; 1210
|
|
#\x253e ;; 1211
|
|
#\x2544 ;; 1212
|
|
#\x252f ;; 1220
|
|
#\x253f ;; 1221
|
|
#\x2547 ;; 1222
|
|
|
|
#\x257b ;; 2000
|
|
#\x257d ;; 2001
|
|
#\x2503 ;; 2002
|
|
#\x2512 ;; 2010
|
|
#\x2527 ;; 2011
|
|
#\x2528 ;; 2012
|
|
#\x2513 ;; 2020
|
|
#\x252a ;; 2021
|
|
#\x252b ;; 2022
|
|
|
|
#\x250e ;; 2100
|
|
#\x251f ;; 2101
|
|
#\x2520 ;; 2102
|
|
#\x2530 ;; 2110
|
|
#\x2541 ;; 2111
|
|
#\x2542 ;; 2112
|
|
#\x2531 ;; 2120
|
|
#\x2545 ;; 2121
|
|
#\x2549 ;; 2122
|
|
|
|
#\x250f ;; 2200
|
|
#\x2522 ;; 2201
|
|
#\x2523 ;; 2202
|
|
#\x2532 ;; 2210
|
|
#\x2546 ;; 2211
|
|
#\x254a ;; 2212
|
|
#\x2533 ;; 2220
|
|
#\x2548 ;; 2221
|
|
#\x254b ;; 2222
|
|
))
|
|
|
|
(define line-cell-char-horizontal-light-dashed #\x254c)
|
|
(define line-cell-char-horizontal-heavy-dashed #\x254d)
|
|
(define line-cell-char-vertical-light-dashed #\x254e)
|
|
(define line-cell-char-vertical-heavy-dashed #\x254f)
|
|
|
|
(define (line-cell->unicode-char cell)
|
|
(cond ((line-cell-straight-horizontal-dashed? cell)
|
|
(let ((thickness (line-cell-straight-horizontal-thickness cell)))
|
|
(if (line-thickness-light? thickness)
|
|
line-cell-char-horizontal-light-dashed
|
|
line-cell-char-horizontal-heavy-dashed)))
|
|
((line-cell-straight-vertical-dashed? cell)
|
|
(let ((thickness (line-cell-straight-vertical-thickness cell)))
|
|
(if (line-thickness-light? thickness)
|
|
line-cell-char-vertical-light-dashed
|
|
line-cell-char-vertical-heavy-dashed)))
|
|
(else
|
|
(let ((compressed (line-cell-junction-compress cell)))
|
|
(vector-ref line-cell-char-junctions compressed)))))
|
|
|
|
(define line-cell-string-junctions
|
|
(apply
|
|
vector
|
|
(map utf8-char->string
|
|
(vector->list line-cell-char-junctions))))
|
|
|
|
(define line-cell-string-horizontal-light-dashed
|
|
(utf8-char->string line-cell-char-horizontal-light-dashed))
|
|
(define line-cell-string-horizontal-heavy-dashed
|
|
(utf8-char->string line-cell-char-horizontal-heavy-dashed))
|
|
(define line-cell-string-vertical-light-dashed
|
|
(utf8-char->string line-cell-char-vertical-light-dashed))
|
|
(define line-cell-string-vertical-heavy-dashed
|
|
(utf8-char->string line-cell-char-vertical-heavy-dashed))
|
|
|
|
(define (line-cell->utf8-string cell)
|
|
(cond ((line-cell-straight-horizontal-dashed? cell)
|
|
(let ((thickness (line-cell-straight-horizontal-thickness cell)))
|
|
(if (line-thickness-light? thickness)
|
|
line-cell-string-horizontal-light-dashed
|
|
line-cell-string-horizontal-heavy-dashed)))
|
|
((line-cell-straight-vertical-dashed? cell)
|
|
(let ((thickness (line-cell-straight-vertical-thickness cell)))
|
|
(if (line-thickness-light? thickness)
|
|
line-cell-string-vertical-light-dashed
|
|
line-cell-string-vertical-heavy-dashed)))
|
|
(else
|
|
(let ((compressed (line-cell-junction-compress cell)))
|
|
(vector-ref line-cell-string-junctions compressed)))))
|
|
|
|
(define (line-cell->ascii-char cell)
|
|
(cond ((line-cell-mostly-horizontal? cell)
|
|
#\-)
|
|
((line-cell-mostly-vertical? cell)
|
|
#\|)
|
|
((line-cell-none? cell)
|
|
#\space)
|
|
(else
|
|
#\+)))
|
|
|
|
(define line-cell-reverse-lookup (make-vector 128 line-cell-none))
|
|
(let loop ((idx 1))
|
|
(when (< idx 81)
|
|
(let* ((ch (vector-ref line-cell-char-junctions idx))
|
|
(cp (char->integer ch))
|
|
(ridx (- cp #x2500))
|
|
(n (modulo idx 3))
|
|
(w (modulo (quotient idx 3) 3))
|
|
(e (modulo (quotient idx 9) 3))
|
|
(s (modulo (quotient idx 27) 3)))
|
|
(vector-set! line-cell-reverse-lookup
|
|
ridx
|
|
(make-line-cell (make-line-style n line-type-solid)
|
|
(make-line-style w line-type-solid)
|
|
(make-line-style e line-type-solid)
|
|
(make-line-style s line-type-solid)))
|
|
(loop (add1 idx)))))
|
|
|
|
(define* (char->line-cell char #:bold (bold? #f))
|
|
(case char
|
|
((#\-) (make-straight-horizontal-line-cell bold? 'solid))
|
|
((#\|) (make-straight-vertical-line-cell bold? 'solid))
|
|
((#\+) (make-cross-line-cell bold? 'solid))
|
|
((#\space) line-cell-none)
|
|
(else
|
|
(let ((cp (char->integer char)))
|
|
(cond ((or (< cp #x2500)
|
|
(> cp #x257f))
|
|
line-cell-none)
|
|
(else
|
|
(vector-ref line-cell-reverse-lookup (- cp #x2500))))))))
|
|
|
|
(define (combine-line-char ch1 ch2)
|
|
(line-cell->unicode-char
|
|
(combine-line-cells
|
|
(char->line-cell ch1)
|
|
(char->line-cell ch2))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Style specifications
|
|
|
|
(define (spec->line-thickness spec)
|
|
(case spec
|
|
((light) line-thickness-light)
|
|
((heavy) line-thickness-heavy)
|
|
(else line-thickness-none)))
|
|
|
|
(define (spec->line-type spec)
|
|
(case spec
|
|
((dashed) line-type-dashed)
|
|
((solid) line-type-solid)
|
|
(else line-type-none)))
|
|
|
|
(define (spec->line-style spec)
|
|
(cond ((symbol? spec)
|
|
(case spec
|
|
((light heavy)
|
|
(make-line-style (spec->line-thickness spec)
|
|
line-type-solid))
|
|
((dashed solid)
|
|
(make-line-style line-thickness-light
|
|
(spec->line-type spec)))
|
|
(else 0)))
|
|
((list? spec)
|
|
(let ((res (foldl
|
|
(lambda (acc spec1)
|
|
(combine-line-style
|
|
acc
|
|
(case spec1
|
|
((light heavy)
|
|
(make-line-style (spec->line-thickness spec1)
|
|
line-type-none))
|
|
((dashed solid)
|
|
(make-line-style line-thickness-none
|
|
(spec->line-type spec1)))
|
|
(else line-style-none))))
|
|
line-style-none
|
|
spec)))
|
|
(cond ((and (line-style-thickness-some? res)
|
|
(line-style-type-none? res))
|
|
(set-line-style-type-solid res))
|
|
((and (line-style-thickness-none? res)
|
|
(line-style-type-some? res))
|
|
(set-line-style-thickness-light res))
|
|
(else
|
|
res))))
|
|
(else line-style-none)))
|
|
|
|
(define (line-style-spec? spec)
|
|
(or (memq spec '(none light heavy dashed solid))
|
|
(and (list? spec)
|
|
(let loop ((lst spec))
|
|
(if (null? lst)
|
|
#t
|
|
(if (line-style-spec? (car spec))
|
|
(loop (cdr lst))
|
|
#f))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Cell makers
|
|
|
|
(define-syntax define-spec->line-cell
|
|
(syntax-rules ()
|
|
((_ name spec style a b c d)
|
|
(define (name spec)
|
|
(let ((style (spec->line-style spec)))
|
|
(make-line-cell a b c d))))))
|
|
|
|
(define-spec->line-cell spec->horizontal-line-cell spec style 0 style style 0)
|
|
(define-spec->line-cell spec->vertical-line-cell spec style style 0 0 style)
|
|
|
|
(define-spec->line-cell spec->north-west-line-cell spec style style style 0 0)
|
|
(define-spec->line-cell spec->north-east-line-cell spec style style 0 style 0)
|
|
(define-spec->line-cell spec->south-west-line-cell spec style 0 style 0 style)
|
|
(define-spec->line-cell spec->south-east-line-cell spec style 0 0 style style)
|
|
|
|
(define spec->top-left-corner-line-cell spec->south-east-line-cell)
|
|
(define spec->top-right-corner-line-cell spec->south-west-line-cell)
|
|
(define spec->bottom-left-corner-line-cell spec->north-east-line-cell)
|
|
(define spec->bottom-right-corner-line-cell spec->north-west-line-cell)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Cell extractors
|
|
|
|
(define ((make-line-cell-extractor n w e s) c)
|
|
(let ((sm (if s 15 0))
|
|
(em (if e 240 0))
|
|
(wm (if w 3840 0))
|
|
(nm (if n 61440 0)))
|
|
(bitwise-and c (bitwise-ior sm em wm nm))))
|
|
|
|
(define extract-line-cell-north-west
|
|
(make-line-cell-extractor #t #t #f #f))
|
|
|
|
(define extract-line-cell-north-east
|
|
(make-line-cell-extractor #t #f #t #f))
|
|
|
|
(define extract-line-cell-south-west
|
|
(make-line-cell-extractor #f #t #f #t))
|
|
|
|
(define extract-line-cell-south-east
|
|
(make-line-cell-extractor #f #f #t #t))
|
|
|
|
(define extract-line-cell-top-left extract-line-cell-south-east)
|
|
(define extract-line-cell-top-right extract-line-cell-south-west)
|
|
(define extract-line-cell-bottom-left extract-line-cell-south-east)
|
|
(define extract-line-cell-bottom-right extract-line-cell-south-west)
|
|
|
|
;; Self-tests
|
|
(define (box-drawing-tests!)
|
|
(run-tests
|
|
box-drawing
|
|
(test-equal? spec->line-thickness
|
|
(spec->line-thickness 'none)
|
|
0)
|
|
(test-equal? spec->line-thickness
|
|
(spec->line-thickness 'light)
|
|
1)
|
|
(test-equal? spec->line-thickness
|
|
(spec->line-thickness 'heavy)
|
|
2)
|
|
(test-equal? spec->line-type
|
|
(spec->line-type 'none)
|
|
0)
|
|
(test-equal? spec->line-type
|
|
(spec->line-type 'dashed)
|
|
1)
|
|
(test-equal? spec->line-type
|
|
(spec->line-type 'solid)
|
|
2)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style 'solid) ;; light implied
|
|
#b1001)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style 'dashed) ;; light implied
|
|
#b101)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style 'light) ;; solid implied
|
|
#b1001)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style 'heavy) ;; solid implied
|
|
#b1010)
|
|
(test-equal? combine-line-style
|
|
(combine-line-style #b1001 #b110)
|
|
#b1111)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style '(solid light))
|
|
#b1001)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style '(solid)) ;; light implied
|
|
#b1001)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style '(dashed)) ;; light implied
|
|
#b101)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style '(light)) ;; solid implied
|
|
#b1001)
|
|
(test-equal? spec->line-style
|
|
(spec->line-style '(heavy)) ;; solid implied
|
|
#b1010)
|
|
))
|
|
|
|
)
|