1206 lines
45 KiB
Racket
1206 lines
45 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
"../syntax.ss"
|
|
"const.ss"
|
|
"snip.ss"
|
|
"snip-flags.ss"
|
|
"private.ss")
|
|
|
|
(provide create-mline
|
|
(struct-out mline)
|
|
(struct-out paragraph)
|
|
mline-next
|
|
mline-prev
|
|
(prefix-out
|
|
mline-
|
|
(for-meta
|
|
0
|
|
NIL
|
|
clone-paragraph
|
|
get-line-max-width
|
|
adjust-offsets
|
|
deadjust-offsets
|
|
move-parent!
|
|
rotate-left
|
|
rotate-right
|
|
insert
|
|
delete
|
|
find-line
|
|
find-position
|
|
find-scroll
|
|
find-location
|
|
find-paragraph
|
|
get-line
|
|
get-position
|
|
get-scroll
|
|
get-location
|
|
get-paragraph
|
|
get-paragraph-style
|
|
set-length
|
|
set-scroll-length
|
|
set-height
|
|
calc-line-length
|
|
set-starts-paragraph
|
|
starts-paragraph
|
|
adjust-max-width
|
|
set-width
|
|
scroll-offset
|
|
find-extra-scroll
|
|
mark-recalculate
|
|
adjust-need-calc
|
|
mark-check-flow
|
|
adjust-need-flow
|
|
update-flow
|
|
update-graphics
|
|
get-root
|
|
check-consistent
|
|
first
|
|
last
|
|
get-left-location
|
|
get-right-location
|
|
number)))
|
|
|
|
(define RED #x1)
|
|
(define BLACK #x2)
|
|
(define MAX-W-HERE #x4)
|
|
(define MAX-W-LEFT #x8)
|
|
(define MAX-W-RIGHT #x10)
|
|
(define CALC-HERE #x20)
|
|
(define CALC-LEFT #x40)
|
|
(define CALC-RIGHT #x80)
|
|
(define FLOW-HERE #x100)
|
|
(define FLOW-LEFT #x200)
|
|
(define FLOW-RIGHT #x400)
|
|
(define STARTS-PARA #x800)
|
|
|
|
(define MAX-W-MASK (bitwise-ior MAX-W-HERE MAX-W-LEFT MAX-W-RIGHT))
|
|
(define COLOR-MASK (bitwise-ior RED BLACK))
|
|
(define CALC-MASK (bitwise-ior CALC-HERE CALC-LEFT CALC-RIGHT))
|
|
(define FLOW-MASK (bitwise-ior FLOW-HERE FLOW-LEFT FLOW-RIGHT))
|
|
|
|
(define-struct mline (prev next parent left right
|
|
|
|
flags paragraph
|
|
|
|
;; relative values:
|
|
line pos scroll parno y
|
|
|
|
max-width
|
|
|
|
snip last-snip scroll-snip
|
|
|
|
len numscrolls
|
|
last-h last-w ;; height/width of last snip in line
|
|
h w ;; height/width of line
|
|
bottombase topbase ;; bottom baseline, top baseline (relative)
|
|
)
|
|
#:mutable #:transparent)
|
|
|
|
(define NIL #f)
|
|
|
|
(define (create-mline)
|
|
(make-mline #f #f NIL NIL NIL
|
|
(bitwise-ior BLACK MAX-W-HERE CALC-HERE) #f
|
|
0 0 0 0 0.0
|
|
0.0
|
|
#f #f #f
|
|
0 1
|
|
0.0 0.0
|
|
0.0 0.0
|
|
0.0 0.0))
|
|
|
|
(set! NIL (create-mline))
|
|
(set-mline-parent! NIL NIL)
|
|
(set-mline-left! NIL NIL)
|
|
(set-mline-right! NIL NIL)
|
|
|
|
(define (mline-destroy! m)
|
|
;; Doesn't need to to anything, but this may be helpful for debugging
|
|
(begin
|
|
(set-mline-prev! m 'BAD)
|
|
(set-mline-parent! m 'BAD)
|
|
(set-mline-left! m 'BAD)
|
|
(set-mline-right! m 'BAD)
|
|
(set-mline-flags! m 'BAD)
|
|
(set-mline-paragraph! m 'BAD)
|
|
(set-mline-line! m 'BAD)
|
|
(set-mline-pos! m 'BAD)
|
|
(set-mline-scroll! m 'BAD)
|
|
(set-mline-parno! m 'BAD)
|
|
(set-mline-y! m 'BAD)
|
|
(set-mline-max-width! m 'BAD)
|
|
(set-mline-snip! m 'BAD)
|
|
(set-mline-last-snip! m 'BAD)
|
|
(set-mline-scroll-snip! m 'BAD)
|
|
(set-mline-len! m 'BAD)
|
|
(set-mline-numscrolls! m 'BAD)
|
|
(set-mline-last-h! m 'BAD)
|
|
(set-mline-last-w! m 'BAD)
|
|
(set-mline-h! m 'BAD)
|
|
(set-mline-w! m 'BAD)
|
|
(set-mline-bottombase! m 'BAD)
|
|
(set-mline-topbase! m 'BAD))
|
|
(void))
|
|
|
|
(define (set-red! mline)
|
|
(set-mline-flags! mline (bitwise-ior RED (bitwise-and (mline-flags mline)
|
|
(bitwise-not COLOR-MASK)))))
|
|
(define (set-black! mline)
|
|
(set-mline-flags! mline (bitwise-ior BLACK (bitwise-and (mline-flags mline)
|
|
(bitwise-not COLOR-MASK)))))
|
|
|
|
(define (bit-overlap? a b)
|
|
(not (zero? (bitwise-and a b))))
|
|
|
|
(define (red? mline)
|
|
(bit-overlap? (mline-flags mline) RED))
|
|
(define (black? mline)
|
|
(bit-overlap? (mline-flags mline) BLACK))
|
|
|
|
(define (starts-paragraph mline)
|
|
(if (bit-overlap? STARTS-PARA (mline-flags mline))
|
|
1
|
|
0))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-struct paragraph (left-margin-first
|
|
left-margin
|
|
right-margin
|
|
alignment)
|
|
#:mutable)
|
|
|
|
(define plain-paragraph (make-paragraph 0.0 0.0 0.0 'left))
|
|
|
|
(define (clone-paragraph p)
|
|
(make-paragraph (paragraph-left-margin-first p)
|
|
(paragraph-left-margin p)
|
|
(paragraph-right-margin p)
|
|
(paragraph-alignment p)))
|
|
|
|
(define (get-line-max-width p max-width first?)
|
|
(if (max-width . <= . 0)
|
|
max-width
|
|
(max 1
|
|
(- max-width
|
|
(if first?
|
|
(paragraph-left-margin-first p)
|
|
(paragraph-left-margin p))
|
|
(paragraph-right-margin p)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (adjust-offsets mline newchild)
|
|
(unless (eq? newchild NIL)
|
|
;; Adjust relative values:
|
|
(set-mline-line! newchild (- (mline-line newchild) (+ (mline-line mline) 1)))
|
|
(set-mline-pos! newchild (- (mline-pos newchild) (+ (mline-pos mline) (mline-len mline))))
|
|
(set-mline-scroll! newchild (- (mline-scroll newchild) (+ (mline-scroll mline) (mline-numscrolls mline))))
|
|
(set-mline-y! newchild (- (mline-y newchild) (+ (mline-y mline) (mline-h mline))))
|
|
(set-mline-parno! newchild (- (mline-parno newchild) (+ (mline-parno mline) (starts-paragraph mline))))))
|
|
|
|
(define (deadjust-offsets mline oldchild)
|
|
(unless (eq? oldchild NIL)
|
|
;; Adjust relative values:
|
|
(set-mline-line! oldchild (+ (mline-line oldchild) (+ (mline-line mline) 1)))
|
|
(set-mline-pos! oldchild (+ (mline-pos oldchild) (+ (mline-pos mline) (mline-len mline))))
|
|
(set-mline-scroll! oldchild (+ (mline-scroll oldchild) (+ (mline-scroll mline) (mline-numscrolls mline))))
|
|
(set-mline-y! oldchild (+ (mline-y oldchild) (+ (mline-y mline) (mline-h mline))))
|
|
(set-mline-parno! oldchild (+ (mline-parno oldchild) (+ (mline-parno mline) (starts-paragraph mline))))))
|
|
|
|
(define (move-parent! v x root-box)
|
|
;; replace v with x
|
|
(let ([parent (mline-parent v)])
|
|
(set-mline-parent! x parent) ; x can be NIL!
|
|
(cond
|
|
[(eq? parent NIL)
|
|
(set-box! root-box x)]
|
|
[(eq? v (mline-left parent))
|
|
(set-mline-left! parent x)]
|
|
[else
|
|
(set-mline-right! parent x)])))
|
|
|
|
(define (rotate-left mline root-box)
|
|
(let ([oldright (mline-right mline)])
|
|
(deadjust-offsets mline oldright)
|
|
|
|
(let ([right (mline-left oldright)])
|
|
(set-mline-right! mline right)
|
|
(unless (eq? right NIL)
|
|
(set-mline-parent! right mline)))
|
|
|
|
(move-parent! mline oldright root-box)
|
|
|
|
(set-mline-left! oldright mline)
|
|
(set-mline-parent! mline oldright)
|
|
|
|
(adjust-max-width mline)
|
|
(adjust-need-calc mline)
|
|
(adjust-need-flow mline)
|
|
(adjust-max-width oldright)
|
|
(adjust-need-calc oldright)
|
|
(adjust-need-flow oldright)))
|
|
|
|
(define (rotate-right mline root-box)
|
|
(let ([oldleft (mline-left mline)])
|
|
(adjust-offsets oldleft mline)
|
|
|
|
(let ([left (mline-right oldleft)])
|
|
(set-mline-left! mline left)
|
|
(unless (eq? left NIL)
|
|
(set-mline-parent! left mline)))
|
|
|
|
(move-parent! mline oldleft root-box)
|
|
|
|
(set-mline-right! oldleft mline)
|
|
(set-mline-parent! mline oldleft)
|
|
|
|
(adjust-max-width mline)
|
|
(adjust-need-calc mline)
|
|
(adjust-need-flow mline)
|
|
(adjust-max-width oldleft)
|
|
(adjust-need-calc oldleft)
|
|
(adjust-need-flow oldleft)))
|
|
|
|
(define (insert mline root-box before?)
|
|
(let ([newline (create-mline)])
|
|
(if (eq? (unbox root-box) NIL)
|
|
(begin
|
|
(set-box! root-box newline)
|
|
newline)
|
|
(begin
|
|
(set-red! newline)
|
|
|
|
(if before?
|
|
(let ([prev (mline-prev mline)])
|
|
(set-mline-prev! newline prev)
|
|
(when prev
|
|
(set-mline-next! prev newline))
|
|
(set-mline-next! newline mline)
|
|
(set-mline-prev! mline newline))
|
|
(let ([next (mline-next mline)])
|
|
(set-mline-prev! newline mline)
|
|
(set-mline-next! newline next)
|
|
(when next
|
|
(set-mline-prev! next newline))
|
|
(set-mline-next! mline newline)))
|
|
|
|
(let ([node
|
|
(if before?
|
|
(let ([left (mline-left mline)])
|
|
(if (eq? left NIL)
|
|
(begin
|
|
(set-mline-left! mline newline)
|
|
mline)
|
|
(let loop ([node left])
|
|
(let ([right (mline-right node)])
|
|
(if (not (eq? right NIL))
|
|
(loop right)
|
|
(begin
|
|
(set-mline-right! node newline)
|
|
node))))))
|
|
(let ([right (mline-right mline)])
|
|
(if (eq? right NIL)
|
|
(begin
|
|
(set-mline-right! mline newline)
|
|
mline)
|
|
(let loop ([node right])
|
|
(let ([left (mline-left node)])
|
|
(if (not (eq? left NIL))
|
|
(loop left)
|
|
(begin
|
|
(set-mline-left! node newline)
|
|
node)))))))])
|
|
(set-mline-parent! newline node)
|
|
(adjust-need-calc node #t))
|
|
|
|
(let loop ([node newline])
|
|
(let ([parent (mline-parent node)])
|
|
(unless (eq? parent NIL)
|
|
(when (eq? node (mline-left parent))
|
|
(deadjust-offsets newline parent))
|
|
(loop parent))))
|
|
|
|
(let loop ([node newline])
|
|
(when (and (not (eq? node (unbox root-box)))
|
|
(red? (mline-parent node)))
|
|
(let ([parent (mline-parent node)])
|
|
(if (eq? parent (mline-left (mline-parent parent)))
|
|
(let ([v (mline-right (mline-parent parent))])
|
|
(if (red? v)
|
|
(begin
|
|
(set-black! parent)
|
|
(set-black! v)
|
|
(let ([node (mline-parent parent)])
|
|
(set-red! node)
|
|
(loop node)))
|
|
(let* ([node (if (eq? node (mline-right parent))
|
|
(begin
|
|
(rotate-left parent root-box)
|
|
parent)
|
|
node)]
|
|
[parent (mline-parent node)])
|
|
(set-black! parent)
|
|
(let ([node (mline-parent parent)])
|
|
(set-red! node)
|
|
(rotate-right node root-box)
|
|
(loop node)))))
|
|
(let ([v (mline-left (mline-parent parent))])
|
|
(if (red? v)
|
|
(begin
|
|
(set-black! parent)
|
|
(set-black! v)
|
|
(let ([node (mline-parent parent)])
|
|
(set-red! node)
|
|
(loop node)))
|
|
(let* ([node (if (eq? node (mline-left parent))
|
|
(begin
|
|
(rotate-right parent root-box)
|
|
parent)
|
|
node)]
|
|
[parent (mline-parent node)])
|
|
(set-black! parent)
|
|
(let ([node (mline-parent parent)])
|
|
(set-red! node)
|
|
(rotate-left node root-box)
|
|
(loop node)))))))))
|
|
|
|
(set-black! (unbox root-box))
|
|
|
|
newline))))
|
|
|
|
(define (delete mline root-box)
|
|
|
|
;; adjust ancestor offsets
|
|
(let ([len (mline-len mline)]
|
|
[numscrolls (mline-numscrolls mline)]
|
|
[h (mline-h mline)])
|
|
(let loop ([v mline])
|
|
(let ([parent (mline-parent v)])
|
|
(unless (eq? parent NIL)
|
|
(if (eq? v (mline-right parent))
|
|
(loop parent)
|
|
(let ([v parent])
|
|
(set-mline-line! v (- (mline-line v) 1))
|
|
(set-mline-pos! v (- (mline-pos v) len))
|
|
(set-mline-scroll! v (- (mline-scroll v) numscrolls))
|
|
(set-mline-y! v (- (mline-y v) h))
|
|
(set-mline-parno! v (- (mline-parno v) (starts-paragraph mline)))
|
|
(loop v)))))))
|
|
|
|
(let ([v (if (or (eq? (mline-left mline) NIL)
|
|
(eq? (mline-right mline) NIL))
|
|
mline
|
|
(let ([v (mline-next mline)])
|
|
(let loop ([x v])
|
|
(unless (eq? mline (mline-parent x))
|
|
(let ([parent (mline-parent x)])
|
|
(if (eq? x (mline-right parent))
|
|
(loop parent)
|
|
(let ([x parent])
|
|
(set-mline-line! x (- (mline-line x) 1))
|
|
(set-mline-pos! x (- (mline-pos x) (mline-len v)))
|
|
(set-mline-scroll! x (- (mline-scroll x) (mline-numscrolls v)))
|
|
(set-mline-y! x (- (mline-y x) (mline-h v)))
|
|
(set-mline-parno! x (- (mline-parno x) (starts-paragraph v)))
|
|
(loop x))))))
|
|
v))])
|
|
|
|
(let ([x (if (eq? (mline-left v) NIL)
|
|
(mline-right v)
|
|
(mline-left v))])
|
|
(move-parent! v x root-box)
|
|
|
|
(let ([was-black? (black? v)])
|
|
|
|
(if (not (eq? v mline))
|
|
(let ([oldparent (mline-parent v)])
|
|
(if (black? mline)
|
|
(set-black! v)
|
|
(set-red! v))
|
|
|
|
(let ([left (mline-left mline)])
|
|
(set-mline-left! v left)
|
|
(unless (eq? left NIL)
|
|
(set-mline-parent! left v)))
|
|
(let ([right (mline-right mline)])
|
|
(set-mline-right! v right)
|
|
(unless (eq? right NIL)
|
|
(set-mline-parent! right v)))
|
|
(move-parent! mline v root-box)
|
|
(let ([prev (mline-prev mline)])
|
|
(set-mline-prev! v prev)
|
|
(when prev
|
|
(set-mline-next! prev v)))
|
|
|
|
(set-mline-line! v (mline-line mline))
|
|
(set-mline-pos! v (mline-pos mline))
|
|
(set-mline-scroll! v (mline-scroll mline))
|
|
(set-mline-y! v (mline-y mline))
|
|
(set-mline-parno! v (mline-parno mline))
|
|
|
|
(adjust-max-width oldparent #t)
|
|
(adjust-need-calc oldparent #t)
|
|
(adjust-need-flow oldparent #t)
|
|
|
|
(adjust-max-width v #t)
|
|
(adjust-need-calc v #t)
|
|
(adjust-need-flow v #t)
|
|
|
|
(when (eq? (mline-parent x) mline)
|
|
(set-mline-parent! x v)))
|
|
(begin
|
|
(let ([prev (mline-prev mline)]
|
|
[next (mline-next mline)])
|
|
(when prev
|
|
(set-mline-next! prev next))
|
|
(when next
|
|
(set-mline-prev! next prev)))))
|
|
|
|
(when was-black?
|
|
;; fixup
|
|
(let loop ([x x])
|
|
(if (and (not (eq? x (unbox root-box)))
|
|
(black? x))
|
|
(let ([parent (mline-parent x)])
|
|
(if (eq? x (mline-left parent))
|
|
(let* ([z (mline-right parent)]
|
|
[z (if (red? z)
|
|
(begin
|
|
(set-black! z)
|
|
(set-red! parent)
|
|
(rotate-left parent root-box)
|
|
(mline-right (mline-parent x)))
|
|
z)]
|
|
[x (if (and (black? (mline-left z))
|
|
(black? (mline-right z)))
|
|
(begin
|
|
(set-red! z)
|
|
(mline-parent x))
|
|
(let ([z (if (black? (mline-right z))
|
|
(begin
|
|
(set-black! (mline-left z))
|
|
(set-red! z)
|
|
(rotate-right z root-box)
|
|
(mline-right (mline-parent x)))
|
|
z)])
|
|
(if (red? (mline-parent x))
|
|
(set-red! z)
|
|
(set-black! z))
|
|
(set-black! (mline-parent x))
|
|
(set-black! (mline-right z))
|
|
(rotate-left (mline-parent x) root-box)
|
|
(unbox root-box)))])
|
|
(loop x))
|
|
(let* ([z (mline-left parent)]
|
|
[z (if (red? z)
|
|
(begin
|
|
(set-black! z)
|
|
(set-red! parent)
|
|
(rotate-right parent root-box)
|
|
(mline-left (mline-parent x)))
|
|
z)]
|
|
[x (if (and (black? (mline-right z))
|
|
(black? (mline-left z)))
|
|
(begin
|
|
(set-red! z)
|
|
(mline-parent x))
|
|
(let ([z (if (black? (mline-left z))
|
|
(begin
|
|
(set-black! (mline-right z))
|
|
(set-red! z)
|
|
(rotate-left z root-box)
|
|
(mline-left (mline-parent x)))
|
|
z)])
|
|
(if (red? (mline-parent x))
|
|
(set-red! z)
|
|
(set-black! z))
|
|
(set-black! (mline-parent x))
|
|
(set-black! (mline-left z))
|
|
(rotate-right (mline-parent x) root-box)
|
|
(unbox root-box)))])
|
|
(loop x))))
|
|
(set-black! x)))))))
|
|
|
|
;; In case we set the parent of NIL:
|
|
(set-mline-parent! NIL NIL)
|
|
|
|
(mline-destroy! mline))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (search mline v v-sel size-sel)
|
|
(let loop ([v v][node mline][prev #f])
|
|
(if (not (eq? node NIL))
|
|
(let ([v2 (v-sel node)]
|
|
[size (size-sel node)])
|
|
(cond
|
|
[(v . < . v2)
|
|
(loop v (mline-left node) node)]
|
|
[(v . >= . (+ v2 size))
|
|
(loop (- v (+ v2 size))
|
|
(mline-right node) node)]
|
|
[else node]))
|
|
prev)))
|
|
|
|
(define (find-line mline line)
|
|
(search mline line mline-line (lambda (mline) 1)))
|
|
|
|
(define (find-position mline pos)
|
|
(search mline pos mline-pos mline-len))
|
|
|
|
(define (find-scroll mline scroll)
|
|
(search mline scroll mline-scroll mline-numscrolls))
|
|
|
|
(define (find-location mline y)
|
|
(search mline y mline-y mline-h))
|
|
|
|
(define (find-paragraph mline parno)
|
|
(search mline parno mline-parno starts-paragraph))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (sum mline v-sel size-sel)
|
|
(let loop ([node mline][v (v-sel mline)])
|
|
(let ([parent (mline-parent node)])
|
|
(if (not (eq? parent NIL))
|
|
(if (eq? node (mline-left parent))
|
|
(loop parent v)
|
|
(loop parent (+ v (v-sel parent) (size-sel parent))))
|
|
v))))
|
|
|
|
(define (get-line mline)
|
|
(sum mline mline-line (lambda (mline) 1)))
|
|
|
|
(define (get-position mline)
|
|
(sum mline mline-pos mline-len))
|
|
|
|
(define (get-scroll mline)
|
|
(sum mline mline-scroll mline-numscrolls))
|
|
|
|
(define (get-location mline)
|
|
(sum mline mline-y mline-h))
|
|
|
|
(define (get-paragraph mline)
|
|
(+ (sum mline mline-parno starts-paragraph)
|
|
(sub1 (starts-paragraph mline))))
|
|
|
|
(define (get-paragraph-style mline [first-box #f])
|
|
(if (bit-overlap? (mline-flags mline) STARTS-PARA)
|
|
(begin
|
|
(when first-box (set-box! first-box #t))
|
|
(mline-paragraph mline))
|
|
(begin
|
|
(when first-box (set-box! first-box #f))
|
|
(let ([root (get-root mline)]
|
|
[p (get-paragraph mline)])
|
|
(let ([pstart (find-paragraph root p)])
|
|
(mline-paragraph pstart))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (adjust mline new-val val-sel val-mut! sel mut!)
|
|
(let ([delta (- new-val (val-sel mline))])
|
|
(val-mut! mline new-val)
|
|
(let loop ([node mline])
|
|
(let ([parent (mline-parent node)])
|
|
(unless (eq? parent NIL)
|
|
(if (eq? node (mline-left parent))
|
|
(begin
|
|
(mut! parent (+ delta (sel parent)))
|
|
(loop parent))
|
|
(loop parent)))))))
|
|
|
|
(define (set-length mline len)
|
|
(adjust mline
|
|
len mline-len set-mline-len!
|
|
mline-pos set-mline-pos!))
|
|
|
|
(define (set-scroll-length mline numscrolls)
|
|
(adjust mline
|
|
numscrolls mline-numscrolls set-mline-numscrolls!
|
|
mline-scroll set-mline-scroll!))
|
|
|
|
(define (set-height mline h)
|
|
(adjust mline
|
|
h mline-h set-mline-h!
|
|
mline-y set-mline-y!))
|
|
|
|
(define (calc-line-length mline)
|
|
(let ([l
|
|
(let ([nexts (snip->next (mline-last-snip mline))])
|
|
(let loop ([asnip (mline-snip mline)][l 0])
|
|
(if (eq? asnip nexts)
|
|
l
|
|
(let ([l (+ l (snip->count asnip))])
|
|
(when (has-flag? (snip->flags asnip) WIDTH-DEPENDS-ON-X)
|
|
(send asnip size-cache-invalid))
|
|
(loop (snip->next asnip) l)))))])
|
|
|
|
(when (not (= l (mline-len mline)))
|
|
(set-length mline l)))
|
|
|
|
(let ([next (mline-next mline)])
|
|
(cond
|
|
[(and next
|
|
(has-flag? (snip->flags (mline-last-snip mline))
|
|
HARD-NEWLINE))
|
|
(when (zero? (starts-paragraph next))
|
|
(set-starts-paragraph next #t))]
|
|
[next
|
|
(when (starts-paragraph next)
|
|
(set-starts-paragraph next #f))]))
|
|
|
|
(let ([prev (mline-prev mline)])
|
|
(cond
|
|
[(or (not prev)
|
|
(has-flag? (snip->flags (mline-last-snip prev))
|
|
HARD-NEWLINE))
|
|
(when (zero? (starts-paragraph mline))
|
|
(set-starts-paragraph mline #t))]
|
|
[(positive? (starts-paragraph mline))
|
|
(set-starts-paragraph mline #f)])))
|
|
|
|
(define (set-starts-paragraph mline starts?)
|
|
(unless (= (if starts? 1 0) (starts-paragraph mline))
|
|
(if starts?
|
|
(begin
|
|
(set-mline-flags! mline
|
|
(bitwise-ior (mline-flags mline) STARTS-PARA))
|
|
(unless (mline-paragraph mline)
|
|
(set-mline-paragraph! mline plain-paragraph)))
|
|
(begin
|
|
(set-mline-flags! mline (- (mline-flags mline) STARTS-PARA))
|
|
(set-mline-paragraph! mline #f)))
|
|
|
|
(let loop ([node mline])
|
|
(let ([parent (mline-parent node)])
|
|
(unless (eq? parent NIL)
|
|
(when (eq? node (mline-left parent))
|
|
(set-mline-parno! parent (+ (mline-parno parent)
|
|
(if starts? 1 -1))))
|
|
(loop parent))))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define (adjust-max-width mline [recur? #f])
|
|
(when (not (eq? mline NIL))
|
|
(let loop ([node mline])
|
|
(let ([old (bitwise-and (mline-flags node) MAX-W-MASK)])
|
|
(let ([which
|
|
(cond
|
|
[(and (not (eq? (mline-right node) NIL))
|
|
((mline-max-width (mline-right node)) . > . (mline-w node))
|
|
(or (eq? (mline-left node) NIL)
|
|
((mline-max-width (mline-right node)) . > . (mline-max-width (mline-left node)))))
|
|
(set-mline-max-width! node (mline-max-width (mline-right node)))
|
|
MAX-W-RIGHT]
|
|
[(and (not (eq? (mline-left node) NIL))
|
|
((mline-max-width (mline-left node)) . > . (mline-w node)))
|
|
(set-mline-max-width! node (mline-max-width (mline-left node)))
|
|
MAX-W-LEFT]
|
|
[else
|
|
(set-mline-max-width! node (mline-w node))
|
|
MAX-W-HERE])])
|
|
(unless (= old which)
|
|
(set-mline-flags! node
|
|
(bitwise-ior
|
|
(bitwise-and (mline-flags node)
|
|
(bitwise-not MAX-W-MASK))
|
|
which)))
|
|
(when recur?
|
|
(let ([parent (mline-parent node)])
|
|
(unless (eq? parent NIL)
|
|
(loop parent)))))))))
|
|
|
|
(define (set-width mline w)
|
|
(set-mline-w! mline w)
|
|
(adjust-max-width mline #t))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (scroll-offset mline p)
|
|
(let ([scroll-snip (mline-scroll-snip mline)])
|
|
(cond
|
|
[(not scroll-snip)
|
|
0.0]
|
|
[(p . >= . (mline-numscrolls mline))
|
|
(mline-h mline)]
|
|
[else
|
|
(send scroll-snip get-scroll-step-offset p)])))
|
|
|
|
(define (find-extra-scroll mline y)
|
|
(cond
|
|
[(y . >= . (mline-h mline))
|
|
(mline-numscrolls mline)]
|
|
[(y . <= . 0)
|
|
0]
|
|
[else
|
|
(let ([scroll-snip (mline-scroll-snip mline)])
|
|
(if (not scroll-snip)
|
|
0
|
|
(send scroll-snip find-scroll-step y)))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (mark-need mline HERE recur)
|
|
(unless (bit-overlap? (mline-flags mline) HERE)
|
|
(set-mline-flags! mline (bitwise-ior (mline-flags mline) HERE))
|
|
(let ([parent (mline-parent mline)])
|
|
(unless (eq? parent NIL)
|
|
(recur parent #t)))))
|
|
|
|
(define (adjust-need-flag mline MASK HERE RIGHT LEFT recur?)
|
|
(let loop ([node mline])
|
|
(let ([old (bitwise-and (mline-flags node) MASK)])
|
|
(let* ([which (bitwise-and old HERE)]
|
|
[which (if (and (not (eq? (mline-right node) NIL))
|
|
(bit-overlap? (mline-flags (mline-right node)) MASK))
|
|
(bitwise-ior which RIGHT)
|
|
which)]
|
|
[which (if (and (not (eq? (mline-left node) NIL))
|
|
(bit-overlap? (mline-flags (mline-left node)) MASK))
|
|
(bitwise-ior which LEFT)
|
|
which)])
|
|
(when (not (= old which))
|
|
(set-mline-flags! node
|
|
(bitwise-ior
|
|
(bitwise-and (mline-flags node)
|
|
(bitwise-not MASK))
|
|
which))
|
|
(when recur?
|
|
(let ([parent (mline-parent node)])
|
|
(unless (eq? parent NIL)
|
|
(loop parent)))))))))
|
|
|
|
(define (mark-recalculate mline)
|
|
(mark-need mline CALC-HERE adjust-need-calc))
|
|
|
|
(define (adjust-need-calc mline [recur? #f])
|
|
(adjust-need-flag mline CALC-MASK CALC-HERE CALC-RIGHT CALC-LEFT recur?))
|
|
|
|
(define (mark-check-flow mline)
|
|
(mark-need mline FLOW-HERE adjust-need-flow))
|
|
|
|
(define (adjust-need-flow mline [recur? #f])
|
|
(adjust-need-flag mline FLOW-MASK FLOW-HERE FLOW-RIGHT FLOW-LEFT recur?))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (get-root mline)
|
|
(let ([parent (mline-parent mline)])
|
|
(if (not (eq? parent NIL))
|
|
(get-root parent)
|
|
mline)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (check-consistent root)
|
|
(unless (black? root)
|
|
(error "root is not black"))
|
|
(let ([l1 (let loop ([mline root])
|
|
(if (eq? mline NIL)
|
|
null
|
|
(begin
|
|
(when (red? mline)
|
|
(unless (black? (mline-left mline))
|
|
(error "red left child is not black"))
|
|
(unless (black? (mline-right mline))
|
|
(error "red right child is not black")))
|
|
(unless (or (eq? (mline-left mline) NIL)
|
|
(eq? (mline-parent (mline-left mline)) mline))
|
|
(error "left and up doesn't work"))
|
|
(unless (or (eq? (mline-right mline) NIL)
|
|
(eq? (mline-parent (mline-right mline)) mline))
|
|
(error "right and up doesn't work"))
|
|
(append
|
|
(loop (mline-left mline))
|
|
(list mline)
|
|
(loop (mline-right mline))))))]
|
|
[l2 (let loop ([mline root])
|
|
(let ([prev (mline-prev mline)])
|
|
(if prev
|
|
(begin
|
|
(unless (eq? (mline-next prev) mline)
|
|
(error "back doesn't go forward"))
|
|
(loop prev))
|
|
(let loop ([mline mline])
|
|
(if mline
|
|
(cons mline (loop (mline-next mline)))
|
|
null)))))])
|
|
(unless (= (length l1) (length l2))
|
|
(error 'check-consistent "different lengths: ~s ~s" (length l1) (length l2)))
|
|
(unless (andmap eq? l1 l2)
|
|
(error "different elems")))
|
|
(let loop ([mline root])
|
|
(if (eq? mline NIL)
|
|
0
|
|
(let ([left (loop (mline-left mline))]
|
|
[right (loop (mline-right mline))])
|
|
(unless (= left right)
|
|
(error "different black counts:" left right))
|
|
(if (black? mline)
|
|
(+ 1 left)
|
|
left))))
|
|
(unless (eq? (mline-parent root) NIL)
|
|
(error "root has non-NIL parent"))
|
|
(unless (black? NIL)
|
|
(error "NIL is non-black"))
|
|
(unless (eq? NIL (mline-parent NIL))
|
|
(error "NIL parent changed"))
|
|
(unless (eq? NIL (mline-left NIL))
|
|
(error "NIL left changed"))
|
|
(unless (eq? NIL (mline-left NIL))
|
|
(error "NIL right changed")))
|
|
|
|
#|
|
|
|
|
Debugging tools:
|
|
|
|
(define (draw p)
|
|
(for-each (lambda (l)
|
|
(display l)
|
|
(newline))
|
|
(paint p)))
|
|
|
|
(define (paint p)
|
|
(if (eq? p NIL)
|
|
'("*")
|
|
(let ([l (paint (mline-left p))]
|
|
[r (paint (mline-right p))])
|
|
(let ([ll (string-length (car l))]
|
|
[rl (string-length (car r))]
|
|
[s ((if (red? p) string-upcase values) (format "~s" (mline-sym p)))])
|
|
(cons
|
|
(string-append (make-string ll #\space)
|
|
s
|
|
(make-string rl #\space))
|
|
(let loop ([l l][r r])
|
|
(cond
|
|
[(null? l) (if (null? r)
|
|
null
|
|
(map (lambda (r)
|
|
(string-append
|
|
(make-string (+ ll (string-length s)) #\space)
|
|
r))
|
|
r))]
|
|
[(null? r) (map (lambda (l)
|
|
(string-append
|
|
l
|
|
(make-string (+ rl (string-length s)) #\space)))
|
|
l)]
|
|
[else (cons (string-append (car l)
|
|
(make-string (string-length s) #\space)
|
|
(car r))
|
|
(loop (cdr l) (cdr r)))])))))))
|
|
|
|
(define (find? root m)
|
|
(or (eq? root m)
|
|
(if (eq? root NIL)
|
|
#f
|
|
(or (find? (mline-left root) m)
|
|
(find? (mline-right root) m)))))
|
|
|
|
|#
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define (update-flow mline root-box media max-width dc notify-delete notify-insert)
|
|
(define (flow-left)
|
|
(if (bit-overlap? (mline-flags mline) FLOW-LEFT)
|
|
(if (and (not (eq? (mline-left mline) NIL))
|
|
(update-flow (mline-left mline) root-box media max-width dc
|
|
notify-delete notify-insert))
|
|
#t
|
|
(begin
|
|
(set-mline-flags! mline (- (mline-flags mline) FLOW-LEFT))
|
|
(flow-here)))
|
|
(flow-here)))
|
|
(define (flow-here)
|
|
(if (bit-overlap? (mline-flags mline) FLOW-HERE)
|
|
(begin
|
|
(set-mline-flags! mline (- (mline-flags mline) FLOW-HERE))
|
|
(let* ([first-line (box #f)]
|
|
[para (get-paragraph-style mline first-line)]
|
|
[line-max-width (get-line-max-width para max-width (unbox first-line))])
|
|
(assert (send media consistent-snip-lines 'pre-check-flow))
|
|
(if (send media check-flow line-max-width dc (get-location mline) (get-position mline) (mline-snip mline))
|
|
(do-flow)
|
|
(flow-right))))
|
|
(flow-right)))
|
|
(define (flow-right)
|
|
(if (bit-overlap? (mline-flags mline) FLOW-RIGHT)
|
|
(if (and (not (eq? (mline-right mline) NIL))
|
|
(update-flow (mline-right mline) root-box media max-width dc
|
|
notify-delete notify-insert))
|
|
#t
|
|
(begin
|
|
(set-mline-flags! mline (- (mline-flags mline) FLOW-RIGHT))
|
|
#f))
|
|
#f))
|
|
(define (do-flow)
|
|
(let loop ([asnip (mline-snip mline)])
|
|
(if (eq? asnip (mline-last-snip mline))
|
|
(begin
|
|
(do-extend-line mline asnip)
|
|
(assert (send media consistent-snip-lines 'post-do-extend-line))
|
|
#t)
|
|
(if (has-flag? (snip->flags asnip) NEWLINE)
|
|
(begin
|
|
(do-new-line asnip)
|
|
(send media consistent-snip-lines 'post-do-new-line)
|
|
#t)
|
|
(begin
|
|
(set-snip-line! asnip mline)
|
|
(loop (snip->next asnip)))))))
|
|
(define (do-new-line asnip)
|
|
;; items pushed to next line or new line was inserted;
|
|
;; current line now ends with ansip (which used to be in the middle of the current line)
|
|
(let ([next (mline-next mline)])
|
|
(let ([nextsnip (if next
|
|
(let loop ([nextsnip (snip->next asnip)])
|
|
(if (and nextsnip
|
|
(not (eq? nextsnip (mline-last-snip next)))
|
|
(not (has-flag? (snip->flags nextsnip) NEWLINE)))
|
|
(loop (snip->next nextsnip))
|
|
nextsnip))
|
|
#f)])
|
|
(if (or (not next)
|
|
(not (eq? nextsnip (mline-last-snip next))))
|
|
;; it was a new line
|
|
(let ([newline (insert mline root-box #f)])
|
|
(set-mline-snip! newline (snip->next asnip))
|
|
(set-mline-last-snip! newline (mline-last-snip mline))
|
|
(set-mline-last-snip! mline asnip)
|
|
|
|
(snips-to-line! newline)
|
|
|
|
(notify-insert newline))
|
|
;; some of this line pushed to next line --- or maybe multiple lines pushed
|
|
;; together into a later line
|
|
(begin
|
|
(set-mline-last-snip! mline asnip)
|
|
(set-snip-line! asnip mline)
|
|
|
|
(let ([nextsnip (snip->next asnip)])
|
|
(set-mline-snip! next nextsnip)
|
|
(do-extend-line next nextsnip))))
|
|
|
|
(calc-line-length mline)
|
|
(mark-recalculate mline))))
|
|
(define (snips-to-line! next)
|
|
(let ([nextsnip (snip->next (mline-last-snip next))])
|
|
(let loop ([asnip (mline-snip next)])
|
|
(unless (eq? asnip nextsnip)
|
|
(set-snip-line! asnip next)
|
|
(loop (snip->next asnip)))))
|
|
(mark-check-flow next)
|
|
(mark-recalculate next)
|
|
(calc-line-length next))
|
|
(define (maybe-delete-line! asnip mline)
|
|
(if (and (mline-next mline)
|
|
(eq? asnip (mline-last-snip (mline-next mline))))
|
|
;; a line was deleted
|
|
(let ([next (mline-next mline)])
|
|
(delete next root-box)
|
|
(notify-delete next)
|
|
#t)
|
|
#f))
|
|
(define (do-extend-line mline asnip)
|
|
;; this line was extended
|
|
(let ([asnip
|
|
(if asnip
|
|
(let loop ([asnip asnip])
|
|
(if (and (snip->next asnip)
|
|
(not (has-flag? (snip->flags asnip) NEWLINE)))
|
|
(begin
|
|
(set-snip-line! asnip mline)
|
|
(maybe-delete-line! asnip mline)
|
|
(loop (snip->next asnip)))
|
|
(begin
|
|
(maybe-delete-line! asnip mline)
|
|
(set-mline-last-snip! mline asnip)
|
|
asnip)))
|
|
(begin
|
|
(set-mline-last-snip! mline (send media get-s-last-snip))
|
|
(let loop ()
|
|
(let ([next (mline-next mline)])
|
|
(when next
|
|
(delete next root-box)
|
|
(notify-delete delete)
|
|
(loop))))
|
|
#f))])
|
|
|
|
(set-snip-line! (mline-last-snip mline) mline)
|
|
|
|
(when (mline-next mline)
|
|
(let ([asnip (snip->next asnip)]
|
|
[next (mline-next mline)])
|
|
(when (or (not (eq? (mline-snip next) asnip))
|
|
(not (has-flag? (snip->flags (mline-last-snip next)) NEWLINE)))
|
|
;; Effect can propogate to more lines, merging the
|
|
;; next several. (Handle prefixing the remains of the source of
|
|
;; the extension to this line onto the next line. Implemented
|
|
;; as the next line eating the next->next line.)
|
|
(set-mline-snip! next asnip)
|
|
(let ([asnip
|
|
(let loop ([asnip asnip])
|
|
(if (and (snip->next asnip)
|
|
(not (has-flag? (snip->flags asnip) NEWLINE)))
|
|
(begin
|
|
(maybe-delete-line! asnip next)
|
|
(set-snip-line! asnip next)
|
|
(loop (snip->next asnip)))
|
|
asnip))])
|
|
(set-snip-line! asnip next)
|
|
(set-mline-last-snip! next asnip)
|
|
(when (mline-next next)
|
|
(unless (maybe-delete-line! asnip next)
|
|
(set-mline-snip! (mline-next next) (snip->next asnip))))
|
|
(calc-line-length next)
|
|
(mark-recalculate next)
|
|
(mark-check-flow next)))))
|
|
|
|
(calc-line-length mline)
|
|
(mark-recalculate mline)))
|
|
;; Try left first....
|
|
(flow-left))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (update-graphics mline media dc)
|
|
(define (update-left)
|
|
(and (bit-overlap? (mline-flags mline) CALC-LEFT)
|
|
(not (eq? (mline-left mline) NIL))
|
|
(update-graphics (mline-left mline) media dc)))
|
|
(define (update-here)
|
|
(and
|
|
(bit-overlap? (mline-flags mline) CALC-HERE)
|
|
(let ([y (get-location mline)]
|
|
[nextsnip (snip->next (mline-last-snip mline))])
|
|
(let loop ([asnip (mline-snip mline)]
|
|
[maxbase 0.0]
|
|
[maxdescent 0.0]
|
|
[maxspace 0.0]
|
|
[maxantidescent 0.0]
|
|
[maxantispace 0.0]
|
|
[totalwidth 0.0]
|
|
[maxscroll 1]
|
|
[scroll-snip #f]
|
|
[last-w 0.0]
|
|
[last-h 0.0])
|
|
(if (not (eq? asnip nextsnip))
|
|
(let-boxes ([w 0.0]
|
|
[h 0.0]
|
|
[descent 0.0]
|
|
[space 0.0])
|
|
(send asnip get-extent dc totalwidth y w h descent space #f #f)
|
|
(let* ([align (send (snip->style asnip) get-alignment)]
|
|
[scroll (send asnip get-num-scroll-steps)]
|
|
[maxbase (max maxbase (- h descent space))]
|
|
[maxdescent (if (eq? align 'bottom)
|
|
(max maxdescent descent)
|
|
maxdescent)]
|
|
[maxantispace (if (eq? align 'bottom)
|
|
maxantispace
|
|
(max maxantispace (- h space)))]
|
|
[maxspace (if (eq? align 'top)
|
|
(max maxspace space)
|
|
maxspace)]
|
|
[maxantidescent (if (eq? align 'top)
|
|
maxantidescent
|
|
(max maxantidescent (- h descent)))]
|
|
[scroll-snip (if (scroll . > . maxscroll)
|
|
asnip
|
|
scroll-snip)]
|
|
[maxscroll (max maxscroll scroll)]
|
|
[totalwidth (+ w totalwidth)])
|
|
(loop (snip->next asnip)
|
|
maxbase maxdescent maxspace maxantidescent maxantispace
|
|
totalwidth maxscroll scroll-snip
|
|
w h)))
|
|
(let ([maxspace (max maxspace (- maxantidescent maxbase))]
|
|
[maxdescent (max maxdescent (- maxantispace maxbase))])
|
|
(set-mline-scroll-snip! mline scroll-snip)
|
|
(set-mline-last-h! mline last-h)
|
|
(set-mline-last-w! mline last-w)
|
|
(set-mline-topbase! mline maxspace)
|
|
(set-mline-bottombase! mline (+ maxspace maxbase))
|
|
(let ([maxh (+ maxbase
|
|
maxdescent
|
|
maxspace
|
|
(send media get-s-line-spacing))]
|
|
[bigwidth (+ (if ((mline-w mline) . > . totalwidth)
|
|
(mline-w mline)
|
|
totalwidth)
|
|
CURSOR-WIDTH
|
|
(let-boxes ([is-first? #f]
|
|
[para #f])
|
|
(set-box! para (get-paragraph-style mline is-first?))
|
|
(if is-first?
|
|
(paragraph-left-margin-first para)
|
|
(paragraph-left-margin para))))])
|
|
(set-width mline totalwidth)
|
|
(unless (= maxscroll (mline-numscrolls mline))
|
|
(set-scroll-length mline maxscroll))
|
|
(if (= maxh (mline-h mline))
|
|
(send media refresh-box 0 y bigwidth maxh)
|
|
(begin
|
|
(set-height mline maxh)
|
|
(let ([bigwidth (max 1e5 ;; really want viewable width, but > ok
|
|
(send media get-s-total-width))]
|
|
[bigheight (+ maxh (send media get-s-total-height))])
|
|
(send media refresh-box 0 y bigwidth bigheight))))))))
|
|
#t)))
|
|
(define (update-right)
|
|
(and (bit-overlap? (mline-flags mline) CALC-RIGHT)
|
|
(not (eq? (mline-right mline) NIL))
|
|
(update-graphics (mline-right mline) media dc)))
|
|
|
|
(let ([left? (update-left)]
|
|
[here? (update-here)]
|
|
[right? (update-right)])
|
|
(set-mline-flags! mline (bitwise-and
|
|
(mline-flags mline)
|
|
(bitwise-not CALC-MASK)))
|
|
(or left? here? right?)))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define (number mline)
|
|
(add1 (get-line (last mline))))
|
|
|
|
(define (first mline)
|
|
(let ([left (mline-left mline)])
|
|
(if (eq? left NIL)
|
|
mline
|
|
(first left))))
|
|
|
|
(define (last mline)
|
|
(let ([right (mline-right mline)])
|
|
(if (eq? right NIL)
|
|
mline
|
|
(last right))))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define (get-left-location mline max-width)
|
|
(let-values ([(para left)
|
|
(if (bit-overlap? (mline-flags mline) STARTS-PARA)
|
|
(let ([para (mline-paragraph mline)])
|
|
(values para
|
|
(paragraph-left-margin-first para)))
|
|
(let ([para (get-paragraph-style mline)])
|
|
(values para
|
|
(paragraph-left-margin para))))])
|
|
(if (and (max-width . > . 0)
|
|
(not (eq? (paragraph-alignment para) 'left)))
|
|
(let ([delta (max 0 (- max-width (mline-w mline)))])
|
|
(if (eq? (paragraph-alignment para) 'right)
|
|
(+ left delta)
|
|
(+ left (/ delta 2))))
|
|
left)))
|
|
|
|
(define (get-right-location mline max-width)
|
|
(+ (get-left-location mline max-width) (mline-w mline)))
|