Skip to content

Commit

Permalink
added page support
Browse files Browse the repository at this point in the history
  • Loading branch information
@hayato-hashimoto
hayato-hashimoto committed May 11, 2012
1 parent 426c815 commit d7e6a47
Show file tree
Hide file tree
Showing 6 changed files with 242 additions and 125 deletions.
1 change: 1 addition & 0 deletions 1/cairolib.scm
View file
Expand Up @@ -3,6 +3,7 @@

(c-load "SDL/SDL.h" :libs "-lSDL")
(c-load "cairo/cairo.h" :libs "-lcairo")
(c-load "cairo/cairo-pdf.h" :libs "-lcairo")

(set! exit (lambda x (quit)))
(define sdl-sf '())
Expand Down
224 changes: 137 additions & 87 deletions 1/frame-and-box.scm
View file
Expand Up @@ -41,8 +41,10 @@
(define-class <frame> ()
((pos :init-keyword :pos :init-value #(0 0))
(size :init-value #(0 0))
(box :init-keyword :box)
(box :init-value #f :init-keyword :box)
(mom :init-value #f :init-keyword :mom)
(kids :init-value '() :init-keyword :kids)
(lines :init-value '())
(style :init-value (make-hash-table) :init-keyword :style)))

(define-class <text-frame> (<frame>)
Expand All @@ -51,6 +53,12 @@
(define-class <br-frame> (<text-frame>)
((text :init-value "")))

(define-class <page-frame> (<frame>)
())

(define-class <line-frame> (<frame>)
())

(define-method write-object ((self <frame>) port)
(cond
((or (not (slot-bound? self 'box)) (not (~ self 'box))) (next-method))
Expand Down Expand Up @@ -85,6 +93,18 @@

(define (debug-message . _) identity)

(define-method move (frame x y)
(define dx (- x (~ frame 'pos 0)))
(define dy (- y (~ frame 'pos 1)))
(let loop ((f frame))
(set! (~ f 'pos) (vector (+ (~ f 'pos 0) dx) (+ (~ f 'pos 1) dy)))
(for-each loop (~ f 'kids))))

(define (get-axis direction)
(case direction
((horizontal) 0)
((vertical page) 1)))

(define-method flow ((f <frame>))
(define ptr (vector 0 0))
(define h 0)
Expand All @@ -93,89 +113,110 @@
(define split-position #f)
(define ptr3 #f)
(define text #f)
(define lines '())
(define current-line '(0))
(define orientation
(get-axis (~ f 'style :flow)))
(define (run-text k)
(if (vector? (~ k 'style :position)) (flow k)
(begin
(set! ptr3 (vector-copy ptr))
; set pointer to the head of frame k
(case (~ f 'style :flow)
((vertical) (rel-move-to ptr 0 (~ k 'style :margin-top))
(set! (~ k 'pos) (map-to <vector> + (~ f 'pos) (vector (+ (~ ptr 0) (~ k 'style :margin-left)) (~ ptr 1)))))
((horizontal) (rel-move-to ptr (~ k 'style :margin-left) 0)
(set! (~ k 'pos) (map-to <vector> + (~ f 'pos) (vector (~ ptr 0) (+ (~ ptr 1) (~ k 'style :margin-top)))))))

; flow the content of frame k, and determine the size of k
(when (not (is-a? k <text-frame>))
(if (not (eq? 'horizontal (~ k 'style :scroll)))
(set! (~ k 'style :max-size 0)
(min
(~ k 'style :max-size 0)
(- (~ f 'style :max-size 0) (~ k 'style :margin-left) (~ k 'style :margin-right)))))
(if (not (eq? 'vertical (~ k 'style :scroll)))
(set! (~ k 'style :max-size 1) (min
(~ k 'style :max-size 1)
(- (~ f 'style :max-size 1) (~ k 'style :margin-top) (~ k 'style :margin-bottom))))))
(when (~ k 'style :flow) (flow k))
; run inline frames
(when (and (not (is-a? k <text-frame>)) (not (~ k 'style :flow))) (for-each run-text (~ k 'kids)))
; set pointer to the tail of frame k
(case (~ f 'style :flow)
((horizontal)
(rel-move-to ptr (+ (~ k 'style :margin-right) (~ k 'style :padding-right) (~ k 'size 0)) 0)
(set! w (max w (min (~ ptr 0) (~ f 'style :max-size 0))))
(set! h (max h (+ (~ k 'style :margin-top) (~ k 'size 1) (~ k 'style :margin-bottom)))))
((vertical)
(rel-move-to ptr 0 (+ (~ k 'style :margin-bottom) (~ k 'style :padding-bottom) (~ k 'size 1)))
(set! w (max w (min (~ ptr 1) (~ f 'style :max-size 1))))
(set! h (max h (+ (~ k 'style :margin-left) (~ k 'size 0) (~ k 'style :margin-right))))))

(let1 continue-to-next-line?
(and
(or (is-a? k <br-frame>) (apply func-or (map >= ptr (map + (~ f 'style :max-size))))) ;XXX
(if (vector? (~ k 'style :position))
(flow k)
(begin
(set! ptr3 (vector-copy ptr))
; set pointer to the head of frame k
(case (~ f 'style :flow)
((horizontal)
(set! (~ ptr 0) 0)
(rel-move-to ptr 0 (* h (~ f 'style :line-height)))
(and (is-a? k <text-frame>) (not (is-a? k <br-frame>))))
((vertical)
(set! (~ ptr 1) 0)
(rel-move-to ptr (* h (~ f 'style :line-height)) 0)
(and (is-a? k <text-frame>) (not (is-a? k <br-frame>))))))

(when continue-to-next-line?
(set! split-position (split-frame f ptr3 k))
(set! h 0)
(set! text (~ k 'text))
(set! (~ k 'text)
(string-copy (~ k 'text) 0 split-position))
(meter% k)
(set! x
(make <text-frame>
:box (~ k 'box)
:style (~ k 'style)
:kids '()
:text (string-copy text split-position)))
(meter% x)
(push! (~ f 'kids) x)
(case (~ f 'style :flow)
((vertical) (rel-move-to ptr 0 (~ k 'style :margin-top)))
((horizontal) (rel-move-to ptr (~ k 'style :margin-left) 0)))
((vertical page) (rel-move-to ptr 0 (~ k 'style :margin-top))
(set! (~ k 'pos) (map-to <vector> + (~ f 'pos) (vector (+ (~ ptr 0) (~ k 'style :margin-left)) (~ ptr 1)))))
((horizontal) (rel-move-to ptr (~ k 'style :margin-left) 0)
(set! (~ k 'pos) (map-to <vector> + (~ f 'pos) (vector (~ ptr 0) (+ (~ ptr 1) (~ k 'style :margin-top)))))))
; flow the content of frame k, and determine the size of k
(when (not (is-a? k <text-frame>))
(if (not (eq? 'horizontal (~ k 'style :scroll)))
(set! (~ k 'style :max-size 0)
(min
(~ k 'style :max-size 0)
(- (~ f 'style :max-size 0) (~ k 'style :margin-left) (~ k 'style :margin-right)))))
(if (not (eq? 'vertical (~ k 'style :scroll)))
(set! (~ k 'style :max-size 1)
(min
(~ k 'style :max-size 1)
(- (~ f 'style :max-size 1) (~ k 'style :margin-top) (~ k 'style :margin-bottom))))))
(when (~ k 'style :flow) (flow k))
; run inline frames
(when (and (not (is-a? k <text-frame>))
(not (~ k 'style :flow)))
(for-each run-text (~ k 'kids)))
; set pointer to the tail of frame k
(case (~ f 'style :flow)
((vertical) (set! (~ x 'pos)
(map-to <vector> +
(~ f 'pos)
(vector (+ (~ ptr 0) (~ k 'style :margin-left)) (~ ptr 1))))
(set! h
(max h
(+ (~ k 'style :margin-left) (~ k 'size 0) (~ k 'style :margin-right)))))
((horizontal) (set! (~ x 'pos)
(map-to <vector> +
(~ f 'pos)
(vector (~ ptr 0) (+ (~ ptr 1) (~ k 'style :margin-top)))))
(set! h
(max h
(+ (~ k 'style :margin-top) (~ k 'size 1) (~ k 'style :margin-bottom))))))
(run-text x))))))
((horizontal)
(rel-move-to ptr (+ (~ k 'style :margin-right) (~ k 'style :padding-right) (~ k 'size 0)) 0)
(set! w (max w (min (~ ptr 0) (~ f 'style :max-size 0))))
(set! h (max h (+ (~ k 'style :margin-top) (~ k 'size 1) (~ k 'style :margin-bottom))))
(push! current-line k))
((vertical page)
(rel-move-to ptr 0 (+ (~ k 'style :margin-bottom) (~ k 'style :padding-bottom) (~ k 'size 1)))
(set! w (max w (min (~ ptr 1) (~ f 'style :max-size 1))))
(set! h (max h (+ (~ k 'style :margin-left) (~ k 'size 0) (~ k 'style :margin-right))))
(push! current-line k)))
(let1 continue-to-next-line?
(and
(or (is-a? k <br-frame>)
(if (eq? (~ f 'style :flow) 'page)
(or (>= (~ ptr 0) (~ f 'style :max-size 0))
(>= (~ ptr 1) (~ f 'style :max-size 1)))
(>= (~ ptr orientation) (~ f 'style :max-size orientation))))
(case (~ f 'style :flow)
((horizontal)
(push! lines (reverse current-line))
(set! current-line (list (~ ptr 0)))
(set! (~ ptr 0) 0)
(rel-move-to ptr 0 (* h (~ f 'style :line-height)))
(and (is-a? k <text-frame>) (not (is-a? k <br-frame>))))
((page)
(set! ptr (vector 0 0))
(set! (~ k 'style :page-break-after) #t)
(and (is-a? k <text-frame>) (not (is-a? k <br-frame>))))
((vertical)
(push! lines (reverse current-line))
(set! current-line (list (~ ptr 1)))
(set! (~ ptr 1) 0)
(rel-move-to ptr (* h (~ f 'style :line-height)) 0)
(and (is-a? k <text-frame>) (not (is-a? k <br-frame>))))))

(when continue-to-next-line?
(set! split-position (split-frame f ptr3 k))
(set! h 0)
(set! text (~ k 'text))
(set! (~ k 'text)
(string-copy (~ k 'text) 0 split-position))
(meter% k)
(set! x
(make <text-frame>
:box (~ k 'box)
:style (~ k 'style)
:kids '()
:mom f
:text (string-copy text split-position)))
(meter% x)
(push! (~ f 'kids) x)
(case (~ f 'style :flow)
((vertical) (rel-move-to ptr 0 (~ k 'style :margin-top)))
((horizontal) (rel-move-to ptr (~ k 'style :margin-left) 0)))
(case (~ f 'style :flow)
((vertical) (set! (~ x 'pos)
(map-to <vector> +
(~ f 'pos)
(vector (+ (~ ptr 0) (~ k 'style :margin-left)) (~ ptr 1))))
(set! h
(max h
(+ (~ k 'style :margin-left) (~ k 'size 0) (~ k 'style :margin-right)))))
((horizontal) (set! (~ x 'pos)
(map-to <vector> +
(~ f 'pos)
(vector (~ ptr 0) (+ (~ ptr 1) (~ k 'style :margin-top)))))
(set! h
(max h
(+ (~ k 'style :margin-top) (~ k 'size 1) (~ k 'style :margin-bottom))))))
(run-text x))))))

(rel-move-to ptr (~ f 'style :padding-left) (~ f 'style :padding-top))

Expand All @@ -184,28 +225,37 @@
(when (vector? (~ f 'style :position)) (set! (~ f 'pos) (~ f 'style :position)))
(for-each run-text (~ f 'kids))
(case (~ f 'style :flow)
((vertical) (rel-move-to ptr (* h (~ f 'style :line-height)) 0))
((horizontal) (rel-move-to ptr 0 (* h (~ f 'style :line-height)))))
((vertical page)
(set! (~ f 'lines) (reverse lines))
(rel-move-to ptr (* h (~ f 'style :line-height)) 0))
((horizontal)
(set! (~ f 'lines) (reverse lines))
(rel-move-to ptr 0 (* h (~ f 'style :line-height)))))
(set! (~ f 'size) (debug-if 'test (vector
(max
(case (~ f 'style :flow)
((vertical) (+ (~ ptr 0) (~ f 'style :padding-right)))
((vertical page) (+ (~ ptr 0) (~ f 'style :padding-right)))
((horizontal) (+ (~ f 'style :padding-left) w (~ f 'style :padding-right))))
(~ f 'style :min-size 0))
(max
(case (~ f 'style :flow)
((vertical) (+ (~ f 'style :padding-top) w (~ f 'style :padding-bottom)))
((vertical page) (+ (~ f 'style :padding-top) w (~ f 'style :padding-bottom)))
((horizontal) (+ (~ ptr 1) (~ f 'style :padding-bottom))))
(~ f 'style :min-size 1)))))
;#?=((debug-message "exiting flow ...") f)
)

(define (move-pointer-dry-run f ptr v m)
(define orientation
(get-axis (~ f 'style :flow)))
(define ptr2 (vector-copy ptr))
(case (~ f 'style :flow)
((horizontal) (rel-move-to ptr2 (+ (~ m 'style :margin-right) (~ v 0)) 0))
((vertical) (rel-move-to ptr2 0 (+ (~ m 'style :margin-bottom) (~ v 1)))))
(apply func-or (map >= ptr2 (~ f 'style :max-size))))
((vertical page) (rel-move-to ptr2 0 (+ (~ m 'style :margin-bottom) (~ v 1)))))
(if (eq? (~ f 'style :flow) 'page)
(or (>= (~ ptr2 0) (~ f 'style :max-size 0))
(>= (~ ptr2 1) (~ f 'style :max-size 1)))
(>= (~ ptr2 orientation) (~ f 'style :max-size orientation))))

(define (func-or . a)
(if (null? a) #f (or (car a) (apply func-or (cdr a)))))
Expand Down
58 changes: 49 additions & 9 deletions 1/paint.scm
View file
Expand Up @@ -3,19 +3,26 @@
(load "./parser.scm")
(use srfi-27)
(define repaint? #f)
(define-method paint (c (f <frame>))
(paint-content c f)
(for-each (cut paint c <>) (~ f 'kids)))
(define-method paint (cr (f <frame>) media)
(paint-content cr f media)
(for-each (cut paint cr <> media) (~ f 'kids)))

(define (paged-media? media)
(case media
((screen) #f)
((pdf) #t)))

(define-method set-source-color ((cr (ptr <cairo_t>)) vec)
(if (eq? 3 (vector-length vec))
(set-source-rgb cr (~ vec 0) (~ vec 1) (~ vec 2))
(set-source-rgba cr (~ vec 0) (~ vec 1) (~ vec 2) (~ vec 3))))

(define-method paint-content (c (f <frame>))
(define cr (~ c 'cairo))
(define x (~ f 'pos 0))
(define y (~ f 'pos 1))
(define-method paint-content (cr (f <line-frame>) media)
(for-each (lambda (ff) (paint-content cr ff media) (~ f 'kids))))

(define-method paint-content (cr (f <frame>) media)
(define x (~ f 'pos 0))
(define y (~ f 'pos 1))
(define move-cairo (lambda () (cairo_move_to cr x y)))

; background
Expand Down Expand Up @@ -70,7 +77,15 @@
(select-font-face cr (~ f 'style :font-face) (slant (~ f 'style :font-slant)) (weight (~ f 'style :font-weight)))
(set-font-size cr (~ f 'style :font-size))
(move-to cr (~ f 'pos 0) (+ (~ f 'pos 1) (~ f 'style :font-size)))
(show-text cr (or (~ f 'text) ""))))
(show-text cr (or (~ f 'text) "")))

(when (and (paged-media? media)
(~ f 'style :page-break-after))
(cairo_show_page cr)
(let loop ((mom (~ f 'mom)))
(and mom
(begin (paint-content cr mom media) #t)
(loop (~ mom 'mom))))))

(define (norm len scale accessor)
(case (car len)
Expand Down Expand Up @@ -176,7 +191,7 @@
(set! (~ w 'current-page 'size) (~ w 'frame 'size))
(set! (~ w 'current-page 'cairo-surface) (cairo_image_surface_create CAIRO_FORMAT_ARGB32 (~ w 'current-page 'size 0) (~ w 'current-page 'size 1)))
(set! (~ w 'current-page 'cairo) (cairo_create (~ w 'current-page 'cairo-surface)))
(paint (~ w 'current-page) (~ w 'frame))
(paint (~ w 'current-page 'cairo) (~ w 'frame) 'screen)
(cairo_set_source_surface (~ w 'cairo) (~ w 'current-page 'cairo-surface) (- (~ w 'current-page 'scroll-position 0)) (- (~ w 'current-page 'scroll-position 1)))
(cairo_paint (~ w 'cairo))
(SDL_Flip (~ w 'surface)))
Expand All @@ -186,6 +201,31 @@
(cairo_paint (~ w 'cairo))
(SDL_Flip (~ w 'surface)))

(define-method document->pdf ((w <main-window>) file width height)
(define pdf-surface (cairo_pdf_surface_create file width height))
(define pdf-cairo (cairo_create pdf-surface))
(sst-reset (~ w 'current-page 'document))
(sst-apply (~ w 'current-page 'document) (open-input-file (~ w 'current-page 'stylesheet-uri)))
(set! (~ w 'frame) (spd-frame-construct (~ w 'current-page 'document)))
(update! (~ w 'frame)
(lambda (f)
(let1 ff (make <frame> :kids (list f))
(init-style ff)
(set! (~ f 'style :max-size 1) height)
(set! (~ f 'style :flow) 'page)
(set! (~ f 'mom) ff)
ff)))
(set! (~ w 'frame 'style :max-size 0) width)
(set! (~ w 'frame 'style :flow) 'horizontal)
(meter (~ w 'frame) (text-extent (~ w 'cairo)))
(set! (~ w 'frame 'pos) (vector 0 0))
(flow (~ w 'frame))
;(dump-tree (~ w 'frame))
(paint pdf-cairo (~ w 'frame) 'pdf)
(cairo_show_page pdf-cairo)
(cairo_surface_destroy pdf-surface)
(cairo_destroy pdf-cairo))

(define cache (make-hash-table 'equal?))
(define (get-png file)
(when (not (hash-table-exists? cache file)) (set! (~ cache file) (cairo_image_surface_create_from_png file)))
Expand Down

0 comments on commit d7e6a47

Please sign in to comment.