From b651031ed3093709819d03749fe2f8595b773593 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 23 Jan 2015 18:33:35 -0800 Subject: [PATCH] disgust --- quad/quads-typed.rkt | 32 +++++++++++-- quad/tests-typed.rkt | 104 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 132 insertions(+), 4 deletions(-) create mode 100644 quad/tests-typed.rkt diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 2e46ed3a..1a99183a 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -3,6 +3,8 @@ (require/typed racket/list [flatten ((Listof QuadAttrPair) . -> . (Listof QuadAttrPair))] [empty? ((Listof Any) . -> . Boolean)] ) +(require sugar/debug) +(provide (all-defined-out)) ;; struct implementation @@ -26,7 +28,8 @@ (define-type QuadAttrPair (Pairof QuadAttrKey QuadAttrValue)) -(: gather-common-attrs ((Listof Quad) . -> . (Listof QuadAttrPair))) +(provide gather-common-attrs) +(: gather-common-attrs ((Listof Quad) . -> . (U False (Listof QuadAttrPair)))) (define (gather-common-attrs qs) (: check-cap (QuadAttrPair . -> . Boolean)) (define (check-cap cap) @@ -35,11 +38,13 @@ ([qs qs] [common-attr-pairs : (Listof QuadAttrPair) (if (Quad-attrs (car qs)) - null + (for/list ([kv-pair (in-hash-pairs (Quad-attrs (car qs)))] + #:unless (member (car kv-pair) cannot-be-common-attrs)) + kv-pair) null)]) (cond - [(empty? common-attr-pairs) #f] - [(empty? qs) (flatten common-attr-pairs)] + [(null? common-attr-pairs) #f] + [(null? qs) common-attr-pairs] [else (loop (cdr qs) (filter check-cap common-attr-pairs))]))) @@ -47,6 +52,7 @@ (syntax-case stx () [(_ Id) (with-syntax ( + [id (format-id #'Id "~a" (string->symbol (string-downcase (symbol->string (syntax->datum #'Id)))))] [Ids? (format-id #'Id "~as?" #'Id)] [Quads->Id (format-id #'Id "Quads->~a" #'Id)]) #'(begin @@ -56,12 +62,30 @@ (: Quads->Id ((Listof Quad) . -> . Id)) (define (Quads->Id qs) (Id #hash() '())) + + (provide id) + (: id ((Listof (U QuadAttrKey QuadAttrValue)) . -> . Id)) + (define (id [attrs '()]) + (apply hash attrs)) ))])) +(define quad= equal?) + +(: quad-has-attr? (Quad QuadAttrKey . -> . Boolean)) +(define (quad-has-attr? q key) + (hash-has-key? (Quad-attrs q) key)) (define-quad-type Hello) (define-quad-type Gbye) (define h (Hello #hash((foo . bar)) (list (Hello #hash() '())))) (define h2 (Quads->Hello '())) +(define g (Gbye #hash((foo . bar)) '())) +(gather-common-attrs (list h g)) + +(define-quad-type Word) +(define-quad-type Line) +(define-quad-type Page) +(define-quad-type Spacer) +(define-quad-type Block) \ No newline at end of file diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt new file mode 100644 index 00000000..30318846 --- /dev/null +++ b/quad/tests-typed.rkt @@ -0,0 +1,104 @@ +#lang racket/base +(require "utils.rkt" "wrap.rkt" "quads-typed.rkt" "world.rkt" racket/list racket/format) +(require rackunit) + +(check-equal? (join-attrs (list (box '(width 10)) (box #f "foobar") (hash 'x 10) (list 'width 20))) + (list (cons 'width 10) (cons 'x 10) (cons 'width 20))) + +(check-equal? (flatten-attrs (hash 'foo 'bar) (hash 'x 10)) (apply hash '(foo bar x 10))) +(check-equal? (flatten-attrs (hash 'x -5) (hash 'x 10)) (apply hash '(x 5))) +(check-equal? (merge-attrs (hash 'x -5) (hash 'x 10)) (apply hash '(x 10))) + +(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) '(foo bar)) +(check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) #f) +(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) #f) + +(define b1 (box '(x 10) "1st" (box '(foo bar) "2nd") "3rd")) +(define b1-flattened (list (box '(x 10) "1st") (box '(x 10 foo bar) "2nd") (box '(x 10) "3rd"))) + + +(define b3 (box #f (word) (line) (page))) +(check-true (sequence? b3)) +;(check-equal? (for/list ([i (in-quad b3)]) i) (list (word) (line) (page))) + +(check-true (quad= (flatten-quad b1) b1-flattened)) + + +(define b2 (box '(x 10) (spacer) (box '(x 15) (spacer) (spacer)) (spacer))) +(define b2-flattened (list (spacer '(x 10)) (spacer '(x 25)) (spacer '(x 25)) (spacer '(x 10)))) + +(check-true (quad= (flatten-quad b2) b2-flattened)) +(check-true (quad= (split-quad b2) b2-flattened)) + +(check-true (quad= (flatten-quad (box '(foo 10) (spacer) (box) (spacer))) (list (spacer '(foo 10)) (box '(foo 10)) (spacer '(foo 10))))) + + +(check-equal? (compute-absolute-positions (page '(x 100 y 100) (line '(x 10 y 10) (word '(x 1 y 1) "hello") + (word '(x 2 y 2) "world")))) + (page '(y 100.0 x 100.0) (line '(y 110.0 x 110.0) (word '(y 111.0 x 111.0) "hello")(word '(y 112.0 x 112.0) "world")))) + + +(define b2-exploded (list (word '(x 10) "1") (word '(x 10) "s") (word '(x 10) "t") (word '(x 10 foo bar) "2") (word '(x 10 foo bar) "n") (word '(x 10 foo bar) "d") (word '(x 10) "3") (word '(x 10) "r") (word '(x 10) "d"))) + +(check-true (quad= (split-quad b1) b2-exploded)) + +(let ([world:minimum-last-line-chars 0]) + (check-equal? (map (compose1 Quad-list last Quad-list) (make-pieces (split-quad (block #f "Foo-dog and " (box) " mas\u00adsachu.")))) '(("o") ("g") ("d") () ("s") (".")))) + +(check-false (quad-has-attr? (box) 'foo)) +(check-true (quad-has-attr? (box '(foo bar)) 'foo)) + +(check-equal? (quad-attr-set (box '(foo bar)) 'foo 'zam) (box '(foo zam))) +(check-equal? (quad-attr-set (box #f) 'foo 'zam) (box '(foo zam))) +(check-equal? (quad-attr-set* (box #f) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo))) +(check-equal? (quad-attr-set* (box '(foo bar)) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo))) + +(check-equal? (quad-attr-remove (box '(foo bar zim zam)) 'foo) (box '(zim zam))) +(check-equal? (quad-attr-remove (box #f) 'zim) (box)) +(check-equal? (quad-attr-remove* (box '(foo bar zim zam ding dong)) 'foo 'ding) (box '(zim zam))) +(check-equal? (quad-attr-remove* (box #f) 'zim) (box)) + +;(check-true (quad-ends-with? (box #f "foo") "foo")) +;(check-false (quad-ends-with? (box #f "foo") "food")) +;(check-false (quad-ends-with? (box #f (box #f "foo")) "food")) +;(check-true (quad-ends-with? (box #f (box #f "foo")) "foo")) +;(check-true (quad-ends-with? (box #f (box #f "foo")) "o")) +;(check-true (quad-ends-with? (box #f (box #f (box #f (box #f (box #f "foo-"))))) "-")) + +;(check-equal? (quad-append (box #f "foo") "bar") (box #f "foo" "bar")) +;(check-equal? (quad-append (box #f "foo") (box #f "bar")) (box #f "foo" (box #f "bar"))) + +(check-equal? (quad-last-char (box #f (box #f "foo") "food")) "d") +(check-equal? (quad-last-char (box #f (box #f "foo"))) "o") +(check-equal? (quad-last-char (box #f "foo")) "o") +(check-false (quad-last-char (box))) + +(check-equal? (quad-first-char (box #f (box #f "foo") "bar")) "f") +(check-equal? (quad-first-char (box #f (box #f "foo") "bar")) "f") +(check-equal? (quad-first-char (box #f "foo")) "f") +(check-false (quad-first-char (box))) + +;(check-equal? (quad->string (box '(width 100) "foo")) "foo") +;(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar"))) "foobar") +;(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar") "ino")) "foobarino") +;(check-equal? (quad->string (box '(width 100))) "") + + +;(check-false (whitespace? (~a #\u00A0))) +;(check-true (whitespace/nbsp? (~a #\u00A0))) +;(check-true (whitespace/nbsp? (word #f (~a #\u00A0)))) +;(check-false (whitespace? (format " ~a " #\u00A0))) +;(check-true (whitespace/nbsp? (format " ~a " #\u00A0))) +(define funny-unicode-spaces (map ~a (list #\u2000 #\u2007 #\u2009 #\u200a #\u202f))) +;(check-true (andmap whitespace? funny-unicode-spaces)) +;(check-true (andmap whitespace/nbsp? funny-unicode-spaces)) + + +(require "experimental.rkt") +(define ti (block '(measure 54) "Meg is " (box '(foo 42)) " ally.")) +(define-values (tokens attrs) (make-tokens-and-attrs ti)) +(current-tokens tokens) +(current-token-attrs attrs) +(check-equal? tokens (vector #\M #\e #\g #\space #\i #\s #\space (box) #\space #\a #\l #\l #\y #\.)) +(check-equal? attrs '(#(#hash((measure . 54)) 0 14) #(#hash((foo . 42)) 7 8))) +