diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt new file mode 100644 index 00000000..098baa52 --- /dev/null +++ b/quad/quad2/compile.rkt @@ -0,0 +1,87 @@ +#lang debug racket/base +(require racket/contract racket/function rackunit racket/list "pass.rkt" "drawing.rkt" "quad.rkt") +(provide quad-compile) + +(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)]) + ($quad #f c))) + +(define/contract (make-compiler . passes) + (() #:rest (listof pass/c) + . ->* . (any/c . -> . (listof any/c))) + (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) (andmap has-position? qs)) + #:postcondition (λ (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 ($quad-char q)))] + [else (error 'render-unknown-thing)])) + ($page 'end) ($doc 'end)))) + +(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))) + diff --git a/quad/quad2/drawing.rkt b/quad/quad2/drawing.rkt new file mode 100644 index 00000000..272f9a10 --- /dev/null +++ b/quad/quad2/drawing.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(provide (all-defined-out)) + +(struct $drawing-inst () #:transparent) +(struct $move $drawing-inst (posn) #:transparent) ; an absolute location in coordinate system (not relative to last loc) +(struct $text $drawing-inst (char) #:transparent) +(struct $doc $drawing-inst (inst) #:transparent) +(struct $page $drawing-inst (inst) #:transparent) \ No newline at end of file diff --git a/quad/quad2/main.rkt b/quad/quad2/main.rkt index 9f051ff6..1c506ded 100644 --- a/quad/quad2/main.rkt +++ b/quad/quad2/main.rkt @@ -1,94 +1,13 @@ #lang debug racket/base -(require racket/contract racket/function rackunit) +(require "compile.rkt" "render.rkt" "quad.rkt") -(struct $point (x y) #:transparent #:mutable) -(struct $size (width height) #:transparent #:mutable) -(struct $rect (origin size) #:transparent #:mutable) +(define drawing-insts (parameterize ([current-wrap-width 6]) + #R (quad-compile "Hello this is the radio"))) -(struct $quad (posn char) #:transparent #:mutable) +(render-to-text drawing-insts) -(define/contract (posn-add p0 p1) - ($point? $size? . -> . $point?) - ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) +(render-to-bitmap drawing-insts) -(define/contract (size char) - ($quad? . -> . $size?) - ($size 1 1)) +#;(render-to-html drawing-insts) -(define/contract (advance char) - ($quad? . -> . $size?) - ($size 1 0)) - -(define pass/c ((listof $quad?) . -> . (listof $quad?))) - -(define/contract (quadify str) - (string? . -> . (listof $quad?)) - (for/list ([c (in-string str)]) - ($quad #f c))) - -(define/contract (make-compiler . passes) - (() #:rest (listof pass/c) - . ->* . (string? . -> . (listof $quad?))) - (apply compose1 (reverse (cons quadify passes)))) - -(define-syntax-rule (define-pass (PASS-NAME ARG) - #:precondition PRECOND-PROC - #:postcondition POSTCOND-PROC - EXPRS ...) - (define/contract (PASS-NAME ARG) - pass/c - (unless (PRECOND-PROC ARG) - (error 'precondition-failed)) - (define res (let () EXPRS ...)) - (unless (POSTCOND-PROC res) - (error 'postcondition-failed)) - res)) - -(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) (andmap (λ (q) (not (has-position? q))) qs)) - #:postcondition (λ (qs) (andmap has-position? qs)) - (define frame ($rect ($point 0 0) ($size 5 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 compile (make-compiler layout)) -(check-equal? (compile "Hello world") - (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))) \ No newline at end of file +#;(render-to-pdf drawing-insts) \ No newline at end of file diff --git a/quad/quad2/pass.rkt b/quad/quad2/pass.rkt new file mode 100644 index 00000000..31b5ab49 --- /dev/null +++ b/quad/quad2/pass.rkt @@ -0,0 +1,18 @@ +#lang racket/base +(require racket/contract) +(provide (all-defined-out)) + +(define pass/c (any/c . -> . any/c)) + +(define-syntax-rule (define-pass (PASS-NAME ARG) + #:precondition PRECOND-PROC + #:postcondition POSTCOND-PROC + EXPRS ...) + (define/contract (PASS-NAME ARG) + pass/c + (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 new file mode 100644 index 00000000..52972585 --- /dev/null +++ b/quad/quad2/quad.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(provide (all-defined-out)) + +(struct $point (x y) #:transparent #:mutable) +(struct $size (width height) #:transparent #:mutable) +(struct $rect (origin size) #:transparent #:mutable) + +(struct $quad (posn char) #:transparent #:mutable) + +(define current-wrap-width (make-parameter 5)) \ No newline at end of file diff --git a/quad/quad2/render.rkt b/quad/quad2/render.rkt new file mode 100644 index 00000000..6f0db6d4 --- /dev/null +++ b/quad/quad2/render.rkt @@ -0,0 +1,64 @@ +#lang debug racket/base +(require "pass.rkt" "drawing.rkt" "quad.rkt" racket/match racket/string) +(provide (all-defined-out)) + +(define-syntax-rule (define-render-pass (PASS-NAME ARG) + EXPRS ...) + (define-pass (PASS-NAME ARG) + #:precondition (λ (xs) (and (list? xs) (andmap $drawing-inst? xs))) + #:postcondition values + EXPRS ...)) + +(define-render-pass (render-to-text xs) + (define move-posns (map $move-posn (filter $move? xs))) + (define xmax (add1 (apply max (map $point-x move-posns)))) + (define ymax (add1 (apply max (map $point-y move-posns)))) + (define char-pos-table (make-hasheqv)) + ;; scan over the instructions and record where the chars want to go + (let loop ([current-loc 0+0i][xs xs]) + (unless (null? xs) + (match xs + [(cons ($move ($point x y)) rest) + (loop (make-rectangular x y) rest)] + [(cons ($text c) rest) + (hash-set! char-pos-table current-loc c) + (loop current-loc rest)] + [(cons _ rest) (loop current-loc rest)]))) + ;; fill in a character grid + (displayln + (string-join + (for/list ([y (in-range ymax)]) + (list->string + (for/list ([x (in-range xmax)]) + (hash-ref char-pos-table (make-rectangular x y) #\space)))) "\n"))) + +(require racket/gui) +(define-render-pass (render-to-bitmap xs) + (define move-posns (map $move-posn (filter $move? xs))) + (define xmax (add1 (apply max (map $point-x move-posns)))) + (define ymax (add1 (apply max (map $point-y move-posns)))) + + (define em-scale 30) + (define target (make-bitmap (* em-scale xmax) (* em-scale ymax))) + (define dc (new bitmap-dc% [bitmap target])) + (send dc scale em-scale em-scale) + + (define face-list (get-face-list 'mono)) + (when (null? face-list) + (error 'no-mono-font-available)) + (define my-face (car face-list)) + (send dc set-font (make-font #:size 1 #:face my-face)) + (send dc set-text-foreground "black") + + (let loop ([current-loc 0+0i][xs xs]) + (unless (null? xs) + (match xs + [(cons ($move ($point x y)) rest) + (loop (make-rectangular x y) rest)] + [(cons ($text c) rest) + (send dc draw-text (string c) (real-part current-loc) (imag-part current-loc)) + (loop current-loc rest)] + [(cons _ rest) (loop current-loc rest)]))) + + (make-object image-snip% target)) +