diff --git a/quad/quad2/atomize.rkt b/quad/quad2/atomize.rkt index b5f9f4fe..e1306b9d 100644 --- a/quad/quad2/atomize.rkt +++ b/quad/quad2/atomize.rkt @@ -1,4 +1,8 @@ #lang debug racket/base +(require racket/match + "compile.rkt" + "quad.rkt") +(provide atomize) #| @@ -11,3 +15,11 @@ For instance, the top-level attrs represent a list object that will eventually be the tail of the attrs in every atomized quad. |# +(define-pass (atomize q) + #:precondition quad? + #:postcondition (list-of quad?) + (match (quad-elems q) + [(cons str _) + (for/list ([c (in-string str)]) + (make-quad #:attrs (make-quad-attrs (list (cons 'char c)))))] + [_ (error 'atomize-branch-unimplemented)])) \ No newline at end of file diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt index 31ae8246..b911c980 100644 --- a/quad/quad2/compile.rkt +++ b/quad/quad2/compile.rkt @@ -1,114 +1,29 @@ #lang debug racket/base -(require racket/contract - racket/function - rackunit - racket/list - racket/match - racket/string - racket/format - "pass.rkt" - "drawing.rkt" +(require racket/match "quad.rkt") -(provide quad-compile quad-compile-to-stack stackify valid-tokens) - -(define/contract (posn-add p0 p1) - ($point? $size? . -> . $point?) - ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) - -(define/contract (size char) - (quad? . -> . $size?) - ($size 1 1)) - -(define/contract (advance char) - (quad? . -> . $size?) - ($size 1 0)) - -(define/contract (quadify str) - (string? . -> . (listof quad?)) - (for/list ([c (in-string str)]) - (make-quad #f (make-quad-attrs (list (cons 'char c)))))) - -(define (make-compiler . passes) - (apply compose1 (reverse (cons quadify passes)))) - -(define (min-x rect) ($point-x ($rect-origin rect))) -(define (width rect) ($size-width ($rect-size rect))) -(define (max-x rect) (+ (min-x rect) (width rect))) -(define (min-y rect) ($point-y ($rect-origin rect))) -(define (height rect) ($size-height ($rect-size rect))) -(define (max-y rect) (+ (min-y rect) (height rect))) - -(define/contract (rect-contains-point? rect pt) - ($rect? $point? . -> . boolean?) - (and (<= (min-x rect) ($point-x pt) (max-x rect)) - (<= (min-y rect) ($point-y pt) (max-y rect)))) - -(define/contract (rect-contains-rect? outer inner) - ($rect? $rect? . -> . boolean?) - (and (rect-contains-point? outer ($rect-origin inner)) - (rect-contains-point? outer ($point (max-x inner) (max-y inner))))) - -(define (has-position? q) (not (eq? (quad-posn q) #false))) -(define-pass (layout qs) - #:precondition (λ (qs) (and (list? qs) (andmap (λ (q) (not (has-position? q))) qs))) - #:postcondition (λ (qs) (and (list? qs) (andmap has-position? qs))) - (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30))) - (define (quad-fits? q posn) - (define q-size (size q)) - (define quad-rect ($rect posn q-size)) - (and (rect-contains-rect? frame quad-rect) posn)) - (for/fold ([posn ($point 0 0)] - #:result qs) - ([q (in-list qs)]) - (define first-posn-on-next-line ($point 0 (add1 ($point-y posn)))) - (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits))) - (set-quad-posn! q winning-posn) - (posn-add winning-posn (advance q)))) - -(define-pass (make-drawing-insts qs) - #:precondition (λ (qs) (and (list? qs) (andmap has-position? qs))) - #:postcondition (λ (qs) (and (list? qs) (andmap $drawing-inst? qs))) - (flatten - (list ($doc 'start) ($page 'start) - (for/list ([q (in-list qs)]) - (cond - [(quad? q) - (list ($move (quad-posn q)) ($text (char->integer (quad-char q))))] - [else (error 'render-unknown-thing)])) - ($page 'end) ($doc 'end)))) - -(define valid-tokens '(doc-start doc-end page-start page-end text move)) - -(define-pass (stackify xs) - #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs))) - #:postcondition string? - (define move-points (map $move-posn (filter $move? xs))) - (define xmax (add1 (apply max (map $point-x move-points)))) - (define ymax (add1 (apply max (map $point-y move-points)))) - (string-join - (for/list ([x (in-list xs)]) - (string-join (map ~a (match x - [($move ($point x y)) (list y x 'move)] - [($text charint) (list charint 'text)] - [($doc 'start) '(doc-start)] - [($doc 'end) '(doc-end)] - [($page 'start) (list ymax xmax 'page-start)] - [($page 'end) '(page-end)] - [_ (error 'unknown-drawing-inst)])) " ")) "\n")) - -(define quad-compile-to-stack (make-compiler layout make-drawing-insts stackify)) -(define quad-compile (make-compiler layout make-drawing-insts)) -#;(check-equal? - (list - ($quad ($point 0 0) #\H) - ($quad ($point 1 0) #\e) - ($quad ($point 2 0) #\l) - ($quad ($point 3 0) #\l) - ($quad ($point 4 0) #\o) - ($quad ($point 0 1) #\space) - ($quad ($point 1 1) #\w) - ($quad ($point 2 1) #\o) - ($quad ($point 3 1) #\r) - ($quad ($point 4 1) #\l) - ($quad ($point 0 2) #\d))) - +(provide (all-defined-out)) + +(struct compiler (passes) + #:constructor-name make-compiler + #:guard (λ (procs name) + (unless ((list-of procedure?) procs) + (raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs)) + procs) + #:property prop:procedure + (λ (self input) ((apply compose1 (reverse (compiler-passes self))) input))) + +(define (compiler-append c passes) + (make-compiler (append (compiler-passes c) passes))) + +(define-syntax-rule (define-pass (PASS-NAME ARG OTHER-ARG ...) + #:precondition PRECOND-PROC + #:postcondition POSTCOND-PROC + EXPRS ...) + (define PASS-NAME + (make-compiler (list (λ (ARG OTHER-ARG ...) + (unless (PRECOND-PROC ARG) + (error 'PASS-NAME (format "precondition failed: ~a for value ~v" 'PRECOND-PROC ARG))) + (define res (let () EXPRS ...)) + (unless (POSTCOND-PROC res) + (error 'PASS-NAME (format "postcondition failed: ~a for value ~v" 'POSTCOND-PROC res))) + res))))) \ No newline at end of file diff --git a/quad/quad2/draw.rkt b/quad/quad2/draw.rkt new file mode 100644 index 00000000..7346430a --- /dev/null +++ b/quad/quad2/draw.rkt @@ -0,0 +1,41 @@ +#lang debug racket/base +(require racket/list + racket/string + racket/format + racket/match + "quad.rkt" + "compile.rkt" + "struct.rkt" + "layout.rkt") +(provide (all-defined-out)) + +(define-pass (make-drawing-insts qs) + #:precondition (list-of has-position?) + #:postcondition (list-of $drawing-inst?) + (flatten + (list ($doc 'start) ($page 'start) + (for/list ([q (in-list qs)]) + (cond + [(quad? q) + (list ($move (quad-posn q)) ($text (char->integer (quad-char q))))] + [else (error 'render-unknown-thing)])) + ($page 'end) ($doc 'end)))) + +(define valid-tokens '(doc-start doc-end page-start page-end text move)) + +(define-pass (stackify xs) + #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs))) + #:postcondition string? + (define move-points (map $move-posn (filter $move? xs))) + (define xmax (add1 (apply max (map $point-x move-points)))) + (define ymax (add1 (apply max (map $point-y move-points)))) + (string-join + (for/list ([x (in-list xs)]) + (string-join (map ~a (match x + [($move ($point x y)) (list y x 'move)] + [($text charint) (list charint 'text)] + [($doc 'start) '(doc-start)] + [($doc 'end) '(doc-end)] + [($page 'start) (list ymax xmax 'page-start)] + [($page 'end) '(page-end)] + [_ (error 'unknown-drawing-inst)])) " ")) "\n")) \ No newline at end of file diff --git a/quad/quad2/layout.rkt b/quad/quad2/layout.rkt new file mode 100644 index 00000000..64bb0403 --- /dev/null +++ b/quad/quad2/layout.rkt @@ -0,0 +1,52 @@ +#lang debug racket/base +(require racket/contract + "compile.rkt" + "quad.rkt") +(provide layout) + +(define/contract (posn-add p0 p1) + ($point? $size? . -> . $point?) + ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) + +(define/contract (size char) + (quad? . -> . $size?) + ($size 1 1)) + +(define/contract (advance char) + (quad? . -> . $size?) + ($size 1 0)) + + + +(define (min-x rect) ($point-x ($rect-origin rect))) +(define (width rect) ($size-width ($rect-size rect))) +(define (max-x rect) (+ (min-x rect) (width rect))) +(define (min-y rect) ($point-y ($rect-origin rect))) +(define (height rect) ($size-height ($rect-size rect))) +(define (max-y rect) (+ (min-y rect) (height rect))) + +(define/contract (rect-contains-point? rect pt) + ($rect? $point? . -> . boolean?) + (and (<= (min-x rect) ($point-x pt) (max-x rect)) + (<= (min-y rect) ($point-y pt) (max-y rect)))) + +(define/contract (rect-contains-rect? outer inner) + ($rect? $rect? . -> . boolean?) + (and (rect-contains-point? outer ($rect-origin inner)) + (rect-contains-point? outer ($point (max-x inner) (max-y inner))))) + +(define-pass (layout qs) + #:precondition (list-of has-no-position?) + #:postcondition (list-of has-position?) + (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30))) + (define (quad-fits? q posn) + (define q-size (size q)) + (define quad-rect ($rect posn q-size)) + (and (rect-contains-rect? frame quad-rect) posn)) + (for/fold ([posn ($point 0 0)] + #:result qs) + ([q (in-list qs)]) + (define first-posn-on-next-line ($point 0 (add1 ($point-y posn)))) + (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits))) + (set-quad-posn! q winning-posn) + (posn-add winning-posn (advance q)))) diff --git a/quad/quad2/main.rkt b/quad/quad2/main.rkt index 386b4846..3be726df 100644 --- a/quad/quad2/main.rkt +++ b/quad/quad2/main.rkt @@ -1,5 +1,31 @@ #lang debug racket/base -(require "compile.rkt" "render.rkt" "quad.rkt" racket/string) +(require "layout.rkt" + "render.rkt" + "quad.rkt" + "compile.rkt" + "atomize.rkt" + "layout.rkt" + "draw.rkt" + racket/string + racket/match) + +(define-pass (bootstrap x) + #:precondition values + #:postcondition quad? + (match x + [(? quad?) x] + [(list (? quad?) ...) (make-quad #:elems (list x))] + [_ (make-quad #:elems (list x))])) + + +(define quad-compile (make-compiler (list + bootstrap + atomize + layout + make-drawing-insts))) + +(define quad-compile-to-stack (compiler-append quad-compile + (list stackify))) (define drawing-insts (parameterize ([current-wrap-width 13]) (quad-compile-to-stack "Hello this is the earth"))) diff --git a/quad/quad2/pass.rkt b/quad/quad2/pass.rkt deleted file mode 100644 index b25f4eaf..00000000 --- a/quad/quad2/pass.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket/base -(require racket/contract) -(provide (all-defined-out)) - -(define-syntax-rule (define-pass (PASS-NAME ARG OTHER-ARG ...) - #:precondition PRECOND-PROC - #:postcondition POSTCOND-PROC - EXPRS ...) - (define (PASS-NAME ARG OTHER-ARG ...) - (unless (PRECOND-PROC ARG) - (error 'PASS-NAME (format "precondition failed: ~a" 'PRECOND-PROC))) - (define res (let () EXPRS ...)) - (unless (POSTCOND-PROC res) - (error 'PASS-NAME (format "postcondition failed: ~a" 'POSTCOND-PROC))) - res)) \ No newline at end of file diff --git a/quad/quad2/quad.rkt b/quad/quad2/quad.rkt index 3b3311bd..6be24ac0 100644 --- a/quad/quad2/quad.rkt +++ b/quad/quad2/quad.rkt @@ -9,31 +9,31 @@ (define current-wrap-width (make-parameter 5)) (define current-page-size (make-parameter ($size 10 10))) -(define (quad? x) - (match x - [($quad (? quad-tag?) - (? quad-attrs?) - (? quad-elems?)) #true] - [_ #false])) - -(struct $quad (tag attrs elems) #:transparent #:mutable) - -(define quad-tag $quad-tag) +(define (list-of proc) (λ (x) (and (list? x) (andmap proc x)))) + +(struct quad (tag attrs elems) #:transparent #:mutable + #:constructor-name quad-constructor + #:guard (λ (tag attrs elems name) + (unless (match (list tag attrs elems) + [(list (? quad-tag?) + (? quad-attrs?) + (? quad-elems?)) #true] + [_ #false]) + (error 'no-dice)) + (values tag attrs elems))) + (define (quad-tag? x) (match x [(or (? symbol?) #false) #true] [_ #false])) -(define set-quad-tag! set-$quad-tag!) -(define quad-attrs $quad-attrs) (define (make-quad-attrs alist) (make-hasheq alist)) (define (quad-attrs? x) (hash-eq? x)) -(define set-quad-attrs! set-$quad-attrs!) -(define quad-elems $quad-elems) (define (quad-elems? x) (list? x)) -(define set-quad-elems! set-$quad-elems!) -(define/contract (make-quad tag attrs . elems) - ((quad-tag? quad-attrs?) #:rest quad-elems? . ->* . quad?) - ($quad tag attrs elems)) +(define/contract (make-quad #:tag [tag #false] + #:attrs [attrs (make-quad-attrs null)] + #:elems [elems null]) + (() (#:tag quad-tag? #:attrs quad-attrs? #:elems quad-elems?) . ->* . quad?) + (quad-constructor tag attrs elems)) (define (quad-ref q key [default-val #false]) (hash-ref (quad-attrs q) key default-val)) @@ -52,4 +52,8 @@ (define-quad-field posn) (define-quad-field char) -#;(define q (make-quad 'div (make-hasheq '((hello . "world"))) "fine")) \ No newline at end of file +(define (has-no-position? q) (not (has-position? q))) +(define (has-position? q) (quad-posn q)) + +(module+ test + (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine")))) \ No newline at end of file diff --git a/quad/quad2/render.rkt b/quad/quad2/render.rkt index 41de9582..2f7052b5 100644 --- a/quad/quad2/render.rkt +++ b/quad/quad2/render.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require "pass.rkt" "quad.rkt" "compile.rkt") +(require "compile.rkt" "draw.rkt" "layout.rkt") (provide (all-defined-out)) (struct $renderer (doc-start-func @@ -68,9 +68,7 @@ (λ (x y) (set! current-loc (make-rectangular x y))) (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets)))))) -(define-pass (render inst-str #:using [renderer (current-renderer)]) - #:precondition string? - #:postcondition any/c +(define (render inst-str #:using [renderer (current-renderer)]) (let/ec exit (for/fold ([stack null] #:result (void)) diff --git a/quad/quad2/drawing.rkt b/quad/quad2/struct.rkt similarity index 100% rename from quad/quad2/drawing.rkt rename to quad/quad2/struct.rkt