multi rendering experiment
parent
b6e74fc8b8
commit
7a84b42241
@ -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)))
|
||||||
|
|
@ -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)
|
@ -1,94 +1,13 @@
|
|||||||
#lang debug racket/base
|
#lang debug racket/base
|
||||||
(require racket/contract racket/function rackunit)
|
(require "compile.rkt" "render.rkt" "quad.rkt")
|
||||||
|
|
||||||
(struct $point (x y) #:transparent #:mutable)
|
(define drawing-insts (parameterize ([current-wrap-width 6])
|
||||||
(struct $size (width height) #:transparent #:mutable)
|
#R (quad-compile "Hello this is the radio")))
|
||||||
(struct $rect (origin size) #:transparent #:mutable)
|
|
||||||
|
|
||||||
(struct $quad (posn char) #:transparent #:mutable)
|
(render-to-text drawing-insts)
|
||||||
|
|
||||||
(define/contract (posn-add p0 p1)
|
(render-to-bitmap drawing-insts)
|
||||||
($point? $size? . -> . $point?)
|
|
||||||
($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1))))
|
|
||||||
|
|
||||||
(define/contract (size char)
|
#;(render-to-html drawing-insts)
|
||||||
($quad? . -> . $size?)
|
|
||||||
($size 1 1))
|
|
||||||
|
|
||||||
(define/contract (advance char)
|
#;(render-to-pdf drawing-insts)
|
||||||
($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)))
|
|
@ -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))
|
@ -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))
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue