1475 lines
56 KiB
Racket
1475 lines
56 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/file
|
|
(for-syntax scheme/base)
|
|
"../syntax.ss"
|
|
"cycle.ss"
|
|
"private.ss"
|
|
"wx.ss")
|
|
|
|
(provide mult-color<%>
|
|
add-color<%>
|
|
style-delta%
|
|
style<%>
|
|
style-list%
|
|
the-style-list
|
|
setup-style-reads-writes
|
|
done-style-reads-writes
|
|
read-styles-from-file
|
|
write-styles-to-file)
|
|
|
|
(define default-size
|
|
(or (get-preference 'MrEd:default-font-size)
|
|
(case (system-type)
|
|
[(windows) 10]
|
|
[else 12])))
|
|
|
|
(define black-color (make-object color% 0 0 0))
|
|
|
|
(defclass mult-color% object%
|
|
(define r 0.0)
|
|
(define g 0.0)
|
|
(define b 0.0)
|
|
|
|
(super-new)
|
|
|
|
(def/public (get [box? rb] [box? gb] [box? bb])
|
|
(set-box! rb r)
|
|
(set-box! gb g)
|
|
(set-box! bb b))
|
|
|
|
(def/public (set [real? rf] [real? gf] [real? bf])
|
|
(set! r rf)
|
|
(set! g gf)
|
|
(set! b bf))
|
|
|
|
(def/public (get-r) r)
|
|
(def/public (get-g) g)
|
|
(def/public (get-b) b)
|
|
|
|
(def/public (set-r [real? v])
|
|
(set! r v))
|
|
(def/public (set-g [real? v])
|
|
(set! g v))
|
|
(def/public (set-b [real? v])
|
|
(set! b v)))
|
|
|
|
(define mult-color<%> (class->interface mult-color%))
|
|
|
|
|
|
(defclass add-color% object%
|
|
(define r 0)
|
|
(define g 0)
|
|
(define b 0)
|
|
|
|
(super-new)
|
|
|
|
(def/public (get [box? rb] [box? gb] [box? bb])
|
|
(set-box! rb r)
|
|
(set-box! gb g)
|
|
(set-box! bb b))
|
|
|
|
(def/public (set [exact-integer? rf] [exact-integer? gf] [exact-integer? bf])
|
|
(set! r rf)
|
|
(set! g gf)
|
|
(set! b bf))
|
|
|
|
(def/public (get-r) r)
|
|
(def/public (get-g) g)
|
|
(def/public (get-b) b)
|
|
|
|
(def/public (set-r [exact-integer? v])
|
|
(set! r v))
|
|
(def/public (set-g [exact-integer? v])
|
|
(set! g v))
|
|
(def/public (set-b [exact-integer? v])
|
|
(set! b v)))
|
|
|
|
(define add-color<%> (class->interface add-color%))
|
|
|
|
(define-syntaxes (-on -off -set-on! -set-off! -don -doff -d -send-get define-delta)
|
|
(let ([mk (lambda (form)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ fld)
|
|
(datum->syntax #'fld
|
|
(string->symbol (format form (syntax-e #'fld)))
|
|
#'fld)])))]
|
|
[mk-set (lambda (mk-id)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ fld val)
|
|
#`(set! #,(mk-id #'(_ fld)) val)])))])
|
|
(values (mk "~a-on")
|
|
(mk "~a-off")
|
|
(mk-set (mk "~a-on"))
|
|
(mk-set (mk "~a-off"))
|
|
(mk "style-delta-~a-on")
|
|
(mk "style-delta-~a-off")
|
|
(mk "style-delta-~a")
|
|
(let ([mk-id (mk "get-~a")])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ fld obj)
|
|
#`(send obj #,(mk-id #'(* fld)))])))
|
|
(let ([mk-id (mk "style-delta-~a")])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ fld)
|
|
#`(define #,(mk-id stx)
|
|
(class-field-accessor style-delta% fld))]))))))
|
|
|
|
;; style-delta fields directly accessible only within this module:
|
|
(define-local-member-name
|
|
family
|
|
face
|
|
size-mult
|
|
size-add
|
|
weight-on
|
|
weight-off
|
|
style-on
|
|
style-off
|
|
smoothing-on
|
|
smoothing-off
|
|
underlined-on
|
|
underlined-off
|
|
size-in-pixels-on
|
|
size-in-pixels-off
|
|
transparent-text-backing-on
|
|
transparent-text-backing-off
|
|
foreground-mult
|
|
background-mult
|
|
foreground-add
|
|
background-add
|
|
alignment-on
|
|
alignment-off)
|
|
|
|
(define (family-delta? s)
|
|
(or (eq? s 'base) (family-symbol? s)))
|
|
(define (style-delta? s)
|
|
(or (eq? s 'base) (style-symbol? s)))
|
|
(define (weight-delta? s)
|
|
(or (eq? s 'base) (weight-symbol? s)))
|
|
(define (smoothing-delta? s)
|
|
(or (eq? s 'base) (smoothing-symbol? s)))
|
|
(define (alignment-delta? s)
|
|
(memq s '(base top bottom center)))
|
|
|
|
(define not-supplied (string->uninterned-symbol "[not-supplied]"))
|
|
|
|
(defclass style-delta% object%
|
|
(field-properties [[family-delta? family] 'base]
|
|
[[(make-or-false string?) face] #f]
|
|
[[real? size-mult] 1.0]
|
|
[[exact-integer? size-add] 0]
|
|
[[weight-delta? weight-on] 'base]
|
|
[[weight-delta? weight-off] 'base]
|
|
[[style-delta? style-on] 'base]
|
|
[[style-delta? style-off] 'base]
|
|
[[smoothing-delta? smoothing-on] 'base]
|
|
[[smoothing-delta? smoothing-off] 'base]
|
|
[[bool? underlined-on] #f]
|
|
[[bool? underlined-off] #f]
|
|
[[bool? size-in-pixels-on] #f]
|
|
[[bool? size-in-pixels-off] #f]
|
|
[[bool? transparent-text-backing-on] #f]
|
|
[[bool? transparent-text-backing-off] #f]
|
|
[[alignment-delta? alignment-on] 'base]
|
|
[[alignment-delta? alignment-off] 'base])
|
|
|
|
(field [foreground-mult (new mult-color%)]
|
|
[background-mult (new mult-color%)]
|
|
[foreground-add (new add-color%)]
|
|
[background-add (new add-color%)])
|
|
|
|
(def/public (get-foreground-mult) foreground-mult)
|
|
(def/public (get-background-mult) background-mult)
|
|
(def/public (get-foreground-add) foreground-add)
|
|
(def/public (get-background-add) background-add)
|
|
|
|
(send background-mult set 1.0 1.0 1.0)
|
|
(send foreground-mult set 1.0 1.0 1.0)
|
|
|
|
(init [change-command 'change-nothing]
|
|
[param not-supplied])
|
|
(super-new)
|
|
(do-set-delta change-command param
|
|
(lambda () (init-name 'style-delta%)))
|
|
|
|
(def/public (set-delta [symbol? [change-command 'change-nothing]]
|
|
[any? [param not-supplied]])
|
|
(do-set-delta change-command param (lambda () (method-name 'style-delta% 'set-delta))))
|
|
|
|
(define/private (do-set-delta change-command param get-who)
|
|
(define (check-no-param)
|
|
(unless (eq? param not-supplied)
|
|
(raise-mismatch-error (get-who)
|
|
(format "no extra argument expected for '~a command: " change-command)
|
|
param)))
|
|
(define (check-param pred)
|
|
(unless (pred param)
|
|
(if (eq? param not-supplied)
|
|
(raise-mismatch-error (get-who)
|
|
"missing argument for command: "
|
|
change-command)
|
|
(raise-mismatch-error (get-who)
|
|
(format "bad argument for '~a command: " change-command)
|
|
param))))
|
|
(case change-command
|
|
[(change-nothing)
|
|
(check-no-param)
|
|
(set! family 'base)
|
|
(set! face #f)
|
|
(set! size-mult 1)
|
|
(set! size-add 0)
|
|
(set! weight-on 'base)
|
|
(set! weight-off 'base)
|
|
(set! style-on 'base)
|
|
(set! style-off 'base)
|
|
(set! smoothing-on 'base)
|
|
(set! smoothing-off 'base)
|
|
(set! underlined-on #f)
|
|
(set! underlined-off #f)
|
|
(set! size-in-pixels-off #f)
|
|
(set! size-in-pixels-on #f)
|
|
(set! transparent-text-backing-off #f)
|
|
(set! transparent-text-backing-on #f)
|
|
(set! foreground-mult (new mult-color%))
|
|
(send foreground-mult set 1 1 1)
|
|
(set! foreground-add (new add-color%))
|
|
(set! background-mult (new mult-color%))
|
|
(send background-mult set 1 1 1)
|
|
(set! background-add (new add-color%))
|
|
(set! alignment-on 'base)
|
|
(set! alignment-off 'base)]
|
|
[(change-style)
|
|
(check-param style-delta?)
|
|
(set! style-on param)
|
|
(set! style-off 'base)]
|
|
[(change-weight)
|
|
(check-param weight-delta?)
|
|
(set! weight-on param)
|
|
(set! weight-off 'base)]
|
|
[(change-smoothing)
|
|
(check-param smoothing-delta?)
|
|
(set! smoothing-on param)
|
|
(set! smoothing-off 'base)]
|
|
[(change-underline)
|
|
(check-param bool?)
|
|
(set! underlined-on param)
|
|
(set! underlined-off (not param))]
|
|
[(change-size-in-pixels)
|
|
(check-param bool?)
|
|
(set! size-in-pixels-on param)
|
|
(set! size-in-pixels-off (not param))]
|
|
[(change-size)
|
|
(check-param exact-integer?)
|
|
(set! size-mult 0)
|
|
(set! size-add param)]
|
|
[(change-family)
|
|
(check-param family-delta?)
|
|
(set! family param)
|
|
(set! face #f)]
|
|
[(change-alignment)
|
|
(check-param alignment-delta?)
|
|
(set! alignment-on param)
|
|
(set! alignment-off 'base)]
|
|
[(change-bold)
|
|
(check-no-param)
|
|
(set! weight-on 'bold)
|
|
(set! weight-off 'base)]
|
|
[(change-italic)
|
|
(check-no-param)
|
|
(set! style-on 'italic)
|
|
(set! style-off 'base)]
|
|
[(change-toggle-style)
|
|
(check-param style-delta?)
|
|
(set! style-on param)
|
|
(set! style-off param)]
|
|
[(change-toggle-weight)
|
|
(check-param weight-delta?)
|
|
(set! weight-on param)
|
|
(set! weight-off param)]
|
|
[(change-toggle-smoothing)
|
|
(check-param smoothing-delta?)
|
|
(set! smoothing-on param)
|
|
(set! smoothing-off param)]
|
|
[(change-toggle-underline)
|
|
(check-no-param)
|
|
(set! underlined-on #t)
|
|
(set! underlined-off #t)]
|
|
[(change-toggle-size-in-pixels)
|
|
(check-no-param)
|
|
(set! size-in-pixels-on #t)
|
|
(set! size-in-pixels-off #t)]
|
|
[(change-bigger)
|
|
(check-param exact-integer?)
|
|
(set! size-mult 1)
|
|
(set! size-add param)]
|
|
[(change-smaller)
|
|
(check-param exact-integer?)
|
|
(set! size-mult 1)
|
|
(set! size-add (- param))]
|
|
[(change-normal)
|
|
(check-no-param)
|
|
(set! family 'default)
|
|
(set! face #f)
|
|
(set! size-mult 0)
|
|
(set! size-add default-size)
|
|
(set! weight-on 'normal)
|
|
(set! weight-off 'base)
|
|
(set! style-on 'normal)
|
|
(set! style-off 'base)
|
|
(set! smoothing-on 'default)
|
|
(set! smoothing-off 'base)
|
|
(set! underlined-on #f)
|
|
(set! underlined-off #t)
|
|
(set! size-in-pixels-on #f)
|
|
(set! size-in-pixels-off #t)
|
|
(set! alignment-on 'bottom)
|
|
(set! alignment-off 'base)
|
|
(set-delta 'change-normal-color)]
|
|
[(change-normal-color)
|
|
(check-no-param)
|
|
(send foreground-mult set 0 0 0)
|
|
(send foreground-add set 0 0 0)
|
|
(send background-mult set 0 0 0)
|
|
(send background-add set 255 255 255)]
|
|
[else
|
|
(raise-type-error (get-who)
|
|
"change-command symbol"
|
|
change-command)])
|
|
this)
|
|
|
|
(def/public (set-delta-face [string? name] [symbol? [fam 'default]])
|
|
(set! face (and name (string->immutable-string name)))
|
|
(set! family fam)
|
|
this)
|
|
|
|
(def/public (set-delta-background [(lambda (x) (or (string? x) (x . is-a? . color%))) col])
|
|
(let ([col (if (string? col)
|
|
(or (send the-color-database find-color col)
|
|
black-color)
|
|
col)])
|
|
(set! transparent-text-backing-on #f)
|
|
(set! transparent-text-backing-off #t)
|
|
(send background-mult set 0 0 0)
|
|
(send background-add set (send col red) (send col green) (send col blue))
|
|
this))
|
|
|
|
(def/public (set-delta-foreground [(lambda (x) (or (string? x) (x . is-a? . color%))) col])
|
|
(let ([col (if (string? col)
|
|
(or (send the-color-database find-color col)
|
|
black-color)
|
|
col)])
|
|
(send foreground-mult set 0 0 0)
|
|
(send foreground-add set (send col red) (send col green) (send col blue))
|
|
this))
|
|
|
|
(def/public (collapse [style-delta% delta-in])
|
|
(define-syntax noncollapsable?
|
|
(syntax-rules ()
|
|
[(_ fld base)
|
|
(not (or (and (eq? (-on fld) ((-don fld) delta-in)) (eq? (-off fld) ((-doff fld) delta-in)))
|
|
(and (eq? (-on fld) base) (eq? (-off fld) base))
|
|
(and (eq? ((-don fld) delta-in) base) (eq? ((-doff fld) delta-in) base))
|
|
(and (eq? (-on fld) base) (not (eq? (-off fld) base)))
|
|
(and (eq? (-off fld) base) (not (eq? (-on fld) base)))))]))
|
|
|
|
;; is collapsing possible?
|
|
;; it may not be if add & multiply sequence occurs,
|
|
;; or certain toggling settings conflict
|
|
(if (and (not (zero? size-mult))
|
|
(not (= size-mult 1.0))
|
|
(not (zero? (style-delta-size-add delta-in))))
|
|
#f ; no collapse
|
|
(let-boxes ([ambr 0] [ambb 0] [ambg 0]
|
|
[amfr 0] [amfb 0] [amfg 0]
|
|
[babr 0] [babb 0] [babg 0]
|
|
[bafr 0] [bafb 0] [bafg 0])
|
|
(begin
|
|
(send foreground-mult get amfr amfb amfg)
|
|
(send background-mult get ambr ambb ambg)
|
|
(send (style-delta-foreground-add delta-in) get bafr bafb bafg)
|
|
(send (style-delta-background-add delta-in) get babr babb babg))
|
|
(cond
|
|
[(or (and (not (zero? amfr)) (not (= amfr 1.0)) (not (zero? bafr)))
|
|
(and (not (zero? amfg)) (not (= amfg 1.0)) (not (zero? bafg)))
|
|
(and (not (zero? amfb)) (not (= amfb 1.0)) (not (zero? bafb)))
|
|
(and (not (zero? ambr)) (not (= ambr 1.0)) (not (zero? babr)))
|
|
(and (not (zero? ambg)) (not (= ambg 1.0)) (not (zero? babg)))
|
|
(and (not (zero? ambb)) (not (= ambb 1.0)) (not (zero? babb))))
|
|
#f] ; no collapse
|
|
;; cases: simple or double toggle
|
|
;; no further change
|
|
;; formerly no change
|
|
;; style definitely on
|
|
;; style definitely off
|
|
[(noncollapsable? style 'base) #f]
|
|
[(noncollapsable? weight 'base) #f]
|
|
[(noncollapsable? smoothing 'base) #f]
|
|
[(noncollapsable? alignment 'base) #f]
|
|
[(noncollapsable? underlined #f) #f]
|
|
[(noncollapsable? size-in-pixels #f) #f]
|
|
[(noncollapsable? transparent-text-backing #f) #f]
|
|
[else
|
|
;; collapsing is possible
|
|
(let-boxes ([bmbr 0] [bmbb 0] [bmbg 0]
|
|
[bmfr 0] [bmfb 0] [bmfg 0]
|
|
[aabr 0] [aabb 0] [aabg 0]
|
|
[aafr 0] [aafb 0] [aafg 0])
|
|
(begin (send (style-delta-foreground-mult delta-in) get bmfr bmfb bmfg)
|
|
(send (style-delta-background-mult delta-in) get bmbr bmbb bmbg)
|
|
(send foreground-add get aafr aafb aafg)
|
|
(send background-add get aabr aabb aabg))
|
|
|
|
(set! size-add (+ size-add
|
|
(->long (* size-mult (style-delta-size-add delta-in)))))
|
|
(set! size-mult (* size-mult (style-delta-size-mult delta-in)))
|
|
|
|
(send foreground-mult set (* amfr bmfr) (* amfb bmfb) (* amfg bmfg))
|
|
(send background-mult set (* ambr bmbr) (* ambb bmbb) (* ambg bmbg))
|
|
(send foreground-add set
|
|
(+ aafr (->long (* amfr bafr)))
|
|
(+ aafb (->long (* amfb bafb)))
|
|
(+ aafg (->long (* amfg bafg))))
|
|
(send background-add set
|
|
(+ aabr (->long (* ambr babr)))
|
|
(+ aabb (->long (* ambb babb)))
|
|
(+ aabg (->long (* ambg babg))))
|
|
|
|
(when (eq? family 'base)
|
|
(set! family (style-delta-family delta-in))
|
|
(when (not face)
|
|
(set! face (style-delta-face delta-in))))
|
|
|
|
(let-syntax ([update!
|
|
(syntax-rules ()
|
|
[(_ fld base)
|
|
(cond
|
|
[(and (eq? (-on fld) base) (eq? (-off fld) base))
|
|
(-set-on! fld ((-don fld) delta-in))
|
|
(-set-off! fld ((-doff fld) delta-in))]
|
|
[(and (not (eq? (-on fld) base)) (not (eq? (-off fld) base)))
|
|
(when (and (eq? (-on fld) (-off fld))
|
|
(or (not (eq? ((-don fld) delta-in) 'base))
|
|
(not (eq? ((-doff fld) delta-in) 'base))))
|
|
;; double toggle
|
|
(-set-on! fld 'base)
|
|
(-set-off! fld 'base))])])])
|
|
(update! style 'base)
|
|
(update! weight 'base)
|
|
(update! smoothing 'base)
|
|
(update! alignment 'base)
|
|
(update! underlined #f)
|
|
(update! size-in-pixels #f)
|
|
(update! transparent-text-backing #f)
|
|
|
|
#t))]))))
|
|
|
|
(def/public (equal? [style-delta% delta-in])
|
|
(define-syntax-rule (same? fld)
|
|
(and (eq? (-on fld) ((-don fld) delta-in))
|
|
(eq? (-off fld) ((-doff fld) delta-in))))
|
|
(define-syntax-rule (same-color? fld)
|
|
(let-boxes ([r1 0] [g1 0] [b1 0]
|
|
[r2 0] [g2 0] [b2 0])
|
|
(begin
|
|
(send fld get r1 g1 b1)
|
|
(send ((-d fld) delta-in) get r2 g2 b2))
|
|
(and (= r1 r2) (= g1 g2) (= b1 b2))))
|
|
(and (eq? family (style-delta-family delta-in))
|
|
(or (eq? face (style-delta-face delta-in))
|
|
(and (string? face)
|
|
(string? (style-delta-face delta-in))
|
|
(string=? face (style-delta-face delta-in))))
|
|
(= size-mult (style-delta-size-mult delta-in))
|
|
(= size-add (style-delta-size-add delta-in))
|
|
(same? weight)
|
|
(same? style)
|
|
(same? smoothing)
|
|
(same? alignment)
|
|
(same? underlined)
|
|
(same? size-in-pixels)
|
|
(same? transparent-text-backing)
|
|
(same-color? foreground-mult)
|
|
(same-color? background-mult)
|
|
(same-color? foreground-add)
|
|
(same-color? background-add)))
|
|
|
|
(def/public (copy [style-delta% in])
|
|
(define-syntax-rule (DCOPY fld)
|
|
(set! fld ((-d fld) in)))
|
|
(define-syntax-rule (DCOPY/c fld)
|
|
(let-boxes ([r 0][g 0][b 0])
|
|
(send ((-d fld) in) get r g b)
|
|
(send fld set r g b)))
|
|
(DCOPY family)
|
|
(DCOPY face)
|
|
(DCOPY size-mult)
|
|
(DCOPY size-add)
|
|
(DCOPY weight-on)
|
|
(DCOPY weight-off)
|
|
(DCOPY smoothing-on)
|
|
(DCOPY smoothing-off)
|
|
(DCOPY style-on)
|
|
(DCOPY style-off)
|
|
(DCOPY underlined-on)
|
|
(DCOPY underlined-off)
|
|
(DCOPY size-in-pixels-on)
|
|
(DCOPY size-in-pixels-off)
|
|
(DCOPY transparent-text-backing-on)
|
|
(DCOPY transparent-text-backing-off)
|
|
(DCOPY/c foreground-mult)
|
|
(DCOPY/c foreground-add)
|
|
(DCOPY/c background-mult)
|
|
(DCOPY/c background-add)
|
|
(DCOPY alignment-on)
|
|
(DCOPY alignment-off)))
|
|
|
|
(define-delta family)
|
|
(define-delta face)
|
|
(define-delta size-mult)
|
|
(define-delta size-add)
|
|
(define-delta weight-on)
|
|
(define-delta weight-off)
|
|
(define-delta style-on)
|
|
(define-delta style-off)
|
|
(define-delta smoothing-on)
|
|
(define-delta smoothing-off)
|
|
(define-delta underlined-on)
|
|
(define-delta underlined-off)
|
|
(define-delta size-in-pixels-on)
|
|
(define-delta size-in-pixels-off)
|
|
(define-delta transparent-text-backing-on)
|
|
(define-delta transparent-text-backing-off)
|
|
(define-delta foreground-mult)
|
|
(define-delta background-mult)
|
|
(define-delta foreground-add)
|
|
(define-delta background-add)
|
|
(define-delta alignment-on)
|
|
(define-delta alignment-off)
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define-local-member-name
|
|
s-add-child
|
|
s-remove-child
|
|
s-set-as-basic
|
|
s-update
|
|
get-s-font
|
|
get-s-pen
|
|
get-s-brush
|
|
get-s-alignment
|
|
get-s-trans-text?
|
|
get-s-foreground
|
|
get-s-background
|
|
get-s-base-style
|
|
get-s-join-shift-style
|
|
get-s-nonjoin-delta
|
|
get-s-name
|
|
set-s-font
|
|
set-s-alignment
|
|
set-s-style-list
|
|
set-s-base-style
|
|
set-s-join-shift-style
|
|
set-s-nonjoin-delta
|
|
set-s-name
|
|
set-s-cached-sizes
|
|
set-s-pen
|
|
set-s-brush
|
|
set-s-shift-style)
|
|
|
|
(defclass style% object%
|
|
(super-new)
|
|
|
|
(define style-list #f) ;; points back to the list owning the style
|
|
(define/public (set-s-style-list sl) (set! style-list sl))
|
|
|
|
(define name #f)
|
|
|
|
(define base-style #f)
|
|
|
|
(define join-shift-style #f)
|
|
(define nonjoin-delta #f)
|
|
|
|
(define/public (get-s-name) name)
|
|
(define/public (set-s-name v) (set! name v))
|
|
(define/public (get-s-base-style) base-style)
|
|
(define/public (set-s-base-style v) (set! base-style v))
|
|
(define/public (get-s-join-shift-style) join-shift-style)
|
|
(define/public (get-s-nonjoin-delta) nonjoin-delta)
|
|
(define/public (set-s-join-shift-style v) (set! join-shift-style v))
|
|
(define/public (set-s-nonjoin-delta v) (set! nonjoin-delta v))
|
|
|
|
;; cache computation:
|
|
(define trans-text? #f)
|
|
(define foreground (new color%))
|
|
(define background (new color%))
|
|
(define font #f)
|
|
(define pen #f)
|
|
(define brush #f)
|
|
(define alignment 'bottom)
|
|
|
|
(define cached-sizes 0)
|
|
(define/public (set-s-cached-sizes v) (set! cached-sizes v))
|
|
(define text-width 0.0)
|
|
(define text-height 0.0)
|
|
(define text-descent 0.0)
|
|
(define text-space 0.0)
|
|
|
|
(define children null)
|
|
|
|
(define/public (s-set-as-basic slist)
|
|
(set! style-list slist)
|
|
|
|
(set! name "Basic")
|
|
(set! base-style #f)
|
|
|
|
(set! nonjoin-delta (new style-delta%))
|
|
(send nonjoin-delta set-delta 'change-normal)
|
|
|
|
(set! font (send the-font-list find-or-create-font
|
|
default-size 'default 'normal 'normal))
|
|
(send foreground set 0 0 0)
|
|
(send background set 255 255 255)
|
|
(set! pen (send the-pen-list find-or-create-pen foreground 0 'solid))
|
|
(set! brush (send the-brush-list find-or-create-brush background 'solid))
|
|
(set! alignment 'bottom)
|
|
(set! trans-text? #t))
|
|
|
|
(define/public (s-update basic target propagate? top-level? send-notify?)
|
|
(let ([base (if basic
|
|
(if (or (not style-list)
|
|
(eq? base-style (send style-list basic-style)))
|
|
basic
|
|
(begin
|
|
(send base-style s-update basic target #f #f #t)
|
|
target))
|
|
base-style)]
|
|
[target (or target this)])
|
|
|
|
(if join-shift-style
|
|
|
|
;; join style
|
|
(when style-list
|
|
(if (not (eq? join-shift-style
|
|
(send style-list basic-style)))
|
|
(send join-shift-style s-update base target #f top-level? #t)
|
|
(begin
|
|
(send target set-s-alignment (send base get-s-alignment))
|
|
(send target set-s-font (send base get-s-font))
|
|
(send target set-s-pen (send base get-s-pen))
|
|
(send target set-s-brush (send base get-s-brush))
|
|
(send target set-s-cached-sizes 0)
|
|
(send (send target get-s-foreground) copy-from (send base get-s-foreground))
|
|
(send (send target get-s-background) copy-from (send base get-s-background))
|
|
|
|
(send style-list style-was-changed target)
|
|
(when top-level?
|
|
(send style-list style-was-changed #f)))))
|
|
|
|
;; not a join style
|
|
(let ()
|
|
(define-syntax-rule (match-field* fld default fld-src)
|
|
(let* ([v (-send-get fld fld-src)]
|
|
[match? (eq? v ((-doff fld) nonjoin-delta))]
|
|
[v (if match? default v)])
|
|
(if (or (not match?)
|
|
(and match?
|
|
(not (eq? ((-don fld) nonjoin-delta)
|
|
((-doff fld) nonjoin-delta)))))
|
|
(if (not (eq? ((-don fld) nonjoin-delta) 'base))
|
|
((-don fld) nonjoin-delta)
|
|
v)
|
|
v)))
|
|
(define-syntax-rule (match-field fld default)
|
|
(match-field* fld default (send base get-s-font)))
|
|
(define-syntax-rule (match-bool fld orig)
|
|
(cond
|
|
[(and ((-doff fld) nonjoin-delta)
|
|
((-don fld) nonjoin-delta))
|
|
(not orig)]
|
|
[((-doff fld) nonjoin-delta)
|
|
#f]
|
|
[((-don fld) nonjoin-delta)
|
|
#t]
|
|
[else orig]))
|
|
|
|
(let ([size (min 255
|
|
(max 1
|
|
(+ (->long (* (style-delta-size-mult nonjoin-delta)
|
|
(send (send base get-s-font) get-point-size)))
|
|
(style-delta-size-add nonjoin-delta))))]
|
|
[fam+face (if (and (not (style-delta-face nonjoin-delta))
|
|
(eq? (style-delta-family nonjoin-delta) 'base))
|
|
(let ([font (send base get-s-font)])
|
|
(cons (send font get-family)
|
|
(send font get-face)))
|
|
(let ([fam (style-delta-family nonjoin-delta)])
|
|
(cons (if (eq? fam 'base)
|
|
(send (send base get-s-font) get-family)
|
|
fam)
|
|
(style-delta-face nonjoin-delta))))]
|
|
[style (match-field style 'normal)]
|
|
[weight (match-field weight 'normal)]
|
|
[smoothing (match-field smoothing 'default)]
|
|
[alignment (match-field* alignment 'bottom target)]
|
|
[underlined (match-bool underlined (-send-get underlined (send base get-s-font)))]
|
|
[size-in-pixels (match-bool size-in-pixels (-send-get size-in-pixels (send base get-s-font)))])
|
|
|
|
(send target set-s-alignment alignment)
|
|
|
|
(let ([font (if (cdr fam+face)
|
|
(send the-font-list
|
|
find-or-create-font
|
|
size (cdr fam+face) (car fam+face)
|
|
style weight underlined smoothing size-in-pixels)
|
|
(send the-font-list
|
|
find-or-create-font
|
|
size (car fam+face)
|
|
style weight underlined smoothing size-in-pixels))])
|
|
(send target set-s-font font)
|
|
(send target set-s-cached-sizes 0)
|
|
|
|
(set! trans-text? (match-bool transparent-text-backing
|
|
(send base get-s-trans-text?)))
|
|
|
|
(let ([combine-colors! (lambda (src-col src-mul src-add dest)
|
|
(let ([r (send src-col red)]
|
|
[g (send src-col green)]
|
|
[b (send src-col blue)])
|
|
(let-boxes ([rm 0.0] [gm 0.0] [bm 0.0]
|
|
[rp 0] [gp 0] [bp 0])
|
|
(begin
|
|
(send src-mul get rm gm bm)
|
|
(send src-add get rp gp bp))
|
|
(let ([->color
|
|
(lambda (v)
|
|
(max (min 255 (->long v)) 0))])
|
|
(send dest set
|
|
(->color (+ (* r rm) rp))
|
|
(->color (+ (* g gm) gp))
|
|
(->color (+ (* b bm) bp)))))))])
|
|
(combine-colors! (send base get-s-foreground)
|
|
(style-delta-foreground-mult nonjoin-delta)
|
|
(style-delta-foreground-add nonjoin-delta)
|
|
(send target get-s-foreground))
|
|
(combine-colors! (send base get-s-background)
|
|
(style-delta-background-mult nonjoin-delta)
|
|
(style-delta-background-add nonjoin-delta)
|
|
(send target get-s-background))
|
|
|
|
(send target set-s-pen
|
|
(send the-pen-list find-or-create-pen foreground 0 'solid))
|
|
(send target set-s-brush
|
|
(send the-brush-list find-or-create-brush background 'solid))
|
|
|
|
(when propagate?
|
|
(for-each (lambda (child)
|
|
(send child s-update #f #f #t #f #t))
|
|
children))
|
|
|
|
(when send-notify?
|
|
(when style-list
|
|
(send style-list style-was-changed target)
|
|
(when top-level?
|
|
(send style-list style-was-changed #f)))))))))))
|
|
|
|
(def/public (get-name) name)
|
|
(def/public (get-family) (send font get-family))
|
|
(def/public (get-face) (send font get-face))
|
|
(def/public (get-font) font)
|
|
(def/public (get-size) (send font get-point-size))
|
|
(def/public (get-weight) (send font get-weight))
|
|
(def/public (get-style) (send font get-style))
|
|
(def/public (get-smoothing) (send font get-smoothing))
|
|
(def/public (get-underlined) (send font get-underlined))
|
|
(def/public (get-size-in-pixels) (send font get-size-in-pixels))
|
|
(def/public (get-transparent-text-backing) trans-text?)
|
|
(def/public (get-foreground) (make-object color% foreground))
|
|
(def/public (get-background) (make-object color% background))
|
|
(def/public (get-alignment) alignment)
|
|
(def/public (is-join?) (and join-shift-style #t))
|
|
|
|
(def/public (get-delta [style-delta% d])
|
|
(if join-shift-style
|
|
(send d set-delta 'change-nothing)
|
|
(send d copy nonjoin-delta)))
|
|
|
|
(def/public (set-delta [style-delta% d])
|
|
(unless (or join-shift-style
|
|
(and style-list
|
|
(eq? this (send style-list basic-style))))
|
|
(send nonjoin-delta copy d)
|
|
(s-update #f #f #t #t #t)))
|
|
|
|
(def/public (get-shift-style)
|
|
(or join-shift-style
|
|
(and style-list
|
|
(send style-list basic-style))
|
|
(send the-style-list basic-style)))
|
|
|
|
(def/public (set-shift-style [style<%> style])
|
|
(unless (or (not join-shift-style)
|
|
(not style-list)
|
|
(not (send style-list style-to-index style))
|
|
(send style-list check-for-loop this style))
|
|
(when join-shift-style
|
|
(send join-shift-style s-remove-child this))
|
|
(send style s-add-child this)
|
|
|
|
(set! join-shift-style style)
|
|
(send style-list style-has-new-child style this)
|
|
(s-update #f #f #t #t #t)
|
|
|
|
;; Why twice? Was this a typo in the original code?
|
|
(set! join-shift-style style)
|
|
(s-update #f #f #t #t #t)))
|
|
|
|
(define/public (set-s-shift-style s)
|
|
(set! join-shift-style s))
|
|
|
|
(def/public (get-base-style)
|
|
base-style)
|
|
|
|
(def/public (set-base-style [(make-or-false style<%>) style])
|
|
(when (and style-list
|
|
(not (eq? this (send style-list basic-style))))
|
|
(let ([style (or style
|
|
(send style-list basic-style))])
|
|
(unless (not (send style-list style-to-index style))
|
|
(unless (send style-list check-for-loop this style)
|
|
(when base-style
|
|
(send base-style s-remove-child this))
|
|
|
|
(set! base-style style)
|
|
(send style s-add-child this)
|
|
|
|
(send style-list style-has-new-child style this)
|
|
|
|
(s-update #f #f #t #t #t))))))
|
|
|
|
(define/private (color->rgb c)
|
|
(values (send c red) (send c green) (send c blue)))
|
|
|
|
(def/public (switch-to [dc<%> dc] [(make-or-false style<%>) old-style])
|
|
(let-values ([(afr afg afb) (if old-style (color->rgb (send old-style get-s-foreground)) (values 0 0 0))]
|
|
[(bfr bfg bfb) (color->rgb foreground)]
|
|
[(abr abg abb) (if old-style (color->rgb (send old-style get-s-background)) (values 0 0 0))]
|
|
[(bbr bbg bbb) (color->rgb background)])
|
|
(when (or (not old-style)
|
|
(not (eq? (send old-style get-s-font) font)))
|
|
(send dc set-font font))
|
|
(when (or (not old-style)
|
|
(not (= afr bfr))
|
|
(not (= afb bfb))
|
|
(not (= afg bfg)))
|
|
(send dc set-text-foreground foreground))
|
|
(when (or (not old-style)
|
|
(not (= abr bbr))
|
|
(not (= abb bbb))
|
|
(not (= abg bbg)))
|
|
(send dc set-text-background background))
|
|
(when (or (not old-style)
|
|
(not (eq? (send old-style get-s-pen) pen)))
|
|
(send dc set-pen pen))
|
|
(when (or (not old-style)
|
|
(not (eq? (send old-style get-s-trans-text?) trans-text?)))
|
|
(send dc set-text-mode (if trans-text? 'transparent 'solid)))))
|
|
|
|
(def/public (reset-text-metrics [dc<%> dc])
|
|
(let ([can-cache (send dc cache-font-metrics-key)])
|
|
(unless (and (not (zero? cached-sizes))
|
|
(eq? cached-sizes can-cache))
|
|
(let-values ([(w h d s) (send dc get-text-extent " " font)])
|
|
(set! text-width w)
|
|
(set! text-height h)
|
|
(set! text-descent d)
|
|
(set! text-space s)
|
|
(set! cached-sizes can-cache)))))
|
|
|
|
(def/public (get-text-width [dc<%> dc])
|
|
(reset-text-metrics dc)
|
|
text-width)
|
|
|
|
(def/public (get-text-height [dc<%> dc])
|
|
(reset-text-metrics dc)
|
|
text-height)
|
|
|
|
(def/public (get-text-descent [dc<%> dc])
|
|
(reset-text-metrics dc)
|
|
text-descent)
|
|
|
|
(def/public (get-text-space [dc<%> dc])
|
|
(reset-text-metrics dc)
|
|
text-space)
|
|
|
|
(define/public (s-add-child c)
|
|
(set! children (cons c children)))
|
|
|
|
(define/public (s-remove-child c)
|
|
(set! children (remq c children)))
|
|
|
|
(define/public (get-s-font) font)
|
|
(define/public (set-s-font v) (set! font v))
|
|
(define/public (get-s-pen) pen)
|
|
(define/public (set-s-pen v) (set! pen v))
|
|
(define/public (get-s-brush) brush)
|
|
(define/public (set-s-brush v) (set! brush v))
|
|
(define/public (get-s-alignment) alignment)
|
|
(define/public (set-s-alignment v) (set! alignment v))
|
|
(define/public (get-s-trans-text?) trans-text?)
|
|
(define/public (get-s-foreground) foreground)
|
|
(define/public (get-s-background) background))
|
|
|
|
(define style<%> (class->interface style%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-local-member-name
|
|
do-named-style
|
|
check-for-loop
|
|
get-s-members)
|
|
|
|
(define-struct notify-key (f))
|
|
|
|
(defclass style-list% object%
|
|
|
|
(super-new)
|
|
|
|
(define notifications (make-weak-hash))
|
|
|
|
(define basic (new style%))
|
|
;; note: the file-reader relies on having a new `basic' when the
|
|
;; list is cleared:
|
|
|
|
(send basic s-set-as-basic this)
|
|
|
|
;; children are before parents (reverse order used for reading
|
|
;; and writing a style list to a stream):
|
|
(define members (list basic))
|
|
(define member-count 1)
|
|
(define/public (get-s-members) members)
|
|
|
|
(define (add-member s)
|
|
(set! members (cons s members))
|
|
(set! member-count (add1 member-count)))
|
|
|
|
(def/public (copy [style-list% other])
|
|
(map (lambda (k) (convert k #t))
|
|
(send other get-s-members)))
|
|
|
|
(define/public-final (basic-style) basic)
|
|
|
|
(def/public (find-or-create-style [(make-or-false style<%>) base-style]
|
|
[style-delta% deltain])
|
|
(let ([base-style
|
|
(if (or (not base-style)
|
|
(not (style-to-index base-style)))
|
|
basic
|
|
base-style)])
|
|
|
|
;; collapse deltas:
|
|
(let ([delta (new style-delta%)])
|
|
(send delta copy deltain)
|
|
(let loop ([base-style base-style])
|
|
(if (and (not (send base-style get-s-name))
|
|
(not (send base-style get-s-join-shift-style))
|
|
(send delta collapse (send base-style get-s-nonjoin-delta)))
|
|
(loop (send base-style get-s-base-style))
|
|
|
|
(or
|
|
;; Find existing style that matches:
|
|
(for/or ([s (in-list members)])
|
|
(and (not (send s get-s-name))
|
|
(not (send s get-s-join-shift-style))
|
|
(eq? (send s get-s-base-style) base-style)
|
|
(send delta equal? (send s get-s-nonjoin-delta))
|
|
s))
|
|
|
|
;; Create style
|
|
(let ([s (new style%)])
|
|
(send s set-s-style-list this)
|
|
(send s set-s-name #f)
|
|
(send s set-s-nonjoin-delta delta)
|
|
(send s set-s-base-style base-style)
|
|
(send base-style s-add-child s)
|
|
(send s s-update #f #f #f #f #f) ;; no need to propagate/notify, because we just created it
|
|
(add-member s)
|
|
s)))))))
|
|
|
|
(def/public (find-or-create-join-style [style% base-style]
|
|
[style% shift-style])
|
|
(let ([base-style (if (or (not base-style)
|
|
(not (style-to-index base-style)))
|
|
basic
|
|
base-style)]
|
|
[shift-style (if (or (not shift-style)
|
|
(not (style-to-index shift-style)))
|
|
basic
|
|
shift-style)])
|
|
|
|
(or (for/or ([s (in-list members)])
|
|
(and (not (send s get-s-name))
|
|
(eq? (send s get-s-base-style) base-style)
|
|
(eq? (send s get-s-join-shift-style) shift-style)
|
|
s))
|
|
(let ([s (new style%)])
|
|
(send s set-s-style-list this)
|
|
(send s set-s-name #f)
|
|
(send s set-s-shift-style shift-style)
|
|
(send shift-style s-add-child s)
|
|
(send s set-s-base-style base-style)
|
|
(send base-style s-add-child s)
|
|
(send s s-update #f #f #t #t #t)
|
|
(add-member s)
|
|
s))))
|
|
|
|
(def/public (find-named-style [string? name])
|
|
(for/or ([s (in-list members)])
|
|
(and (equal? name (send s get-s-name))
|
|
s)))
|
|
|
|
(define/public (do-named-style name plain-style replac?)
|
|
(let ([plain-style (if (or (not plain-style)
|
|
(not (style-to-index plain-style)))
|
|
basic
|
|
plain-style)]
|
|
[name (string->immutable-string name)])
|
|
|
|
(let ([style (for/or ([s (in-list members)])
|
|
(and (equal? name (send s get-s-name))
|
|
s))])
|
|
(if (or (and style (not replac?))
|
|
;; can't replace basic style:
|
|
(eq? style basic))
|
|
style
|
|
|
|
(let ([found-style style]
|
|
[style (or style
|
|
(let ([s (new style%)])
|
|
(send s set-s-name name)
|
|
(send s set-s-style-list this)
|
|
(send s set-s-base-style basic)
|
|
s))])
|
|
|
|
;; plain-style must not depend on this style
|
|
;; (otherwise, we'd create a dependency cycle)
|
|
(if (check-for-loop style plain-style)
|
|
style
|
|
|
|
(begin
|
|
(let ([base (send style get-s-base-style)])
|
|
(send base s-remove-child style))
|
|
(let ([shift (send style get-s-join-shift-style)])
|
|
(when shift
|
|
(send shift s-remove-child style)))
|
|
|
|
(let ([shift (send plain-style get-s-join-shift-style)])
|
|
(if shift
|
|
(begin
|
|
(send style set-s-join-shift-style shift)
|
|
(send shift s-add-child style))
|
|
(let ([delta (new style-delta%)])
|
|
(send style set-s-nonjoin-delta delta)
|
|
(unless (eq? plain-style basic)
|
|
(send delta copy (send plain-style get-s-nonjoin-delta))))))
|
|
|
|
(let ([base (if (eq? plain-style basic)
|
|
basic
|
|
(send plain-style get-s-base-style))])
|
|
(send style set-s-base-style base)
|
|
(send base s-add-child style))
|
|
|
|
(send style s-update #f #f #t #t #t)
|
|
|
|
(unless found-style
|
|
(add-member style))
|
|
|
|
style)))))))
|
|
|
|
(def/public (new-named-style [string? name] [style<%> plain-style])
|
|
(do-named-style name plain-style #f))
|
|
|
|
(def/public (replace-named-style [string? name] [style<%> plain-style])
|
|
(do-named-style name plain-style #t))
|
|
|
|
(def/public (convert [style% style] [any? [overwrite? #f]])
|
|
(or
|
|
(and (style-to-index style)
|
|
style)
|
|
(and (send style get-s-name)
|
|
(not overwrite?)
|
|
(find-named-style (send style get-s-name)))
|
|
|
|
(let ([base (or (let ([s (send style get-s-base-style)])
|
|
(and s (convert s)))
|
|
(basic-style))])
|
|
|
|
(let ([newstyle
|
|
(let ([shift (send style get-s-join-shift-style)])
|
|
(if shift
|
|
(find-or-create-join-style
|
|
base
|
|
(convert shift))
|
|
(find-or-create-style base (send style get-s-nonjoin-delta))))])
|
|
|
|
(let ([name (send style get-s-name)])
|
|
(if name
|
|
(if overwrite?
|
|
(replace-named-style name newstyle)
|
|
(new-named-style name newstyle))
|
|
newstyle))))))
|
|
|
|
(def/public (style-was-changed [(make-or-false style%) which])
|
|
(for ([k (in-hash-keys notifications)])
|
|
(k which)))
|
|
|
|
(def/public (notify-on-change [procedure? f])
|
|
(hash-set! notifications f #t)
|
|
(make-notify-key f))
|
|
|
|
(def/public (forget-notification [notify-key? id])
|
|
(hash-remove! notifications (notify-key-f id)))
|
|
|
|
(def/public (check-for-loop [style<%> s] [style<%> p])
|
|
(or (eq? s p)
|
|
(let ([base (send p get-s-base-style)])
|
|
(cond
|
|
[(not base) #f]
|
|
[(send p get-s-join-shift-style)
|
|
=> (lambda (j)
|
|
(or (check-for-loop s (send p get-s-base-style))
|
|
(check-for-loop s j)))]
|
|
[else (check-for-loop s base)]))))
|
|
|
|
(def/public (style-has-new-child [style<%> s] [style<%> c])
|
|
;; need to maintain the invariant that children are in the list
|
|
;; before parents...
|
|
(let ([new-members
|
|
(let loop ([members members][insert? #f])
|
|
(let ([m (car members)])
|
|
(cond
|
|
[(eq? m c) (if insert?
|
|
(cons c (cons s (cdr members)))
|
|
#f)]
|
|
[(eq? m s) (loop (cdr members) #t)]
|
|
[else (let ([rest (loop (cdr members) insert?)])
|
|
(and rest (cons m rest)))])))])
|
|
(when new-members
|
|
(set! members new-members)
|
|
;; May have moved parent after its own parents
|
|
(style-has-new-child (send s get-s-base-style) s)
|
|
(let ([join (send s get-s-join-style)])
|
|
(when join
|
|
(style-has-new-child join s))))))
|
|
|
|
(def/public (number) member-count)
|
|
|
|
(def/public (index-to-style [exact-nonnegative-integer? i])
|
|
(and (i . < . member-count)
|
|
(list-ref members (- member-count i 1))))
|
|
|
|
(def/public (style-to-index [style<%> s])
|
|
(let loop ([members members][i (sub1 member-count)])
|
|
(cond
|
|
[(null? members) #f]
|
|
[(eq? (car members) s) i]
|
|
[else (loop (cdr members) (sub1 i))])))
|
|
|
|
|
|
(def/public (write-to-file [editor-stream-out% f])
|
|
(write-styles-to-file this f))
|
|
|
|
(define/public (map-index-to-style s i list-id)
|
|
(let loop ([sll (send s get-s-sll)])
|
|
(cond
|
|
[(null? sll)
|
|
(error 'map-index-to-style "bad style list index for snip")]
|
|
[(= (style-list-link-list-id (car sll)) list-id)
|
|
(if (eq? (style-list-link-basic (car sll)) basic)
|
|
;; if basic changes, that means list was cleared
|
|
(if (and (style-list-link-style-map (car sll))
|
|
(i . < . (style-list-link-num-mapped-styles (car sll))))
|
|
(vector-ref (style-list-link-style-map (car sll)) i)
|
|
(error 'map-index-to-style "bad style index for snip"))
|
|
basic)]
|
|
[else (loop (cdr sll))])))
|
|
|
|
(define/public (read-style-list f)
|
|
(read-styles-from-file (new style-list%) f 0 (box 0))))
|
|
|
|
(define the-style-list (new style-list%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-struct style-list-link (style-list
|
|
list-id
|
|
basic
|
|
num-mapped-styles
|
|
style-map))
|
|
|
|
(define (setup-style-reads-writes s)
|
|
(send s set-s-sll null))
|
|
|
|
(define (done-style-reads-writes s)
|
|
(send s set-s-sll null))
|
|
|
|
(define (invert ht)
|
|
(make-immutable-hasheq
|
|
(hash-map ht (lambda (k v) (cons v k)))))
|
|
|
|
(define family-ints
|
|
#hasheq((base . -1)
|
|
(decorative . 71)
|
|
(roman . 72)
|
|
(script . 73)
|
|
(swiss . 74)
|
|
(modern . 75)
|
|
(teletype . 76)
|
|
(system . 77)
|
|
(symbol . 78)
|
|
(default . 70)))
|
|
(define int-families (invert family-ints))
|
|
|
|
(define (family-standard-to-this v)
|
|
(hash-ref int-families v 'default))
|
|
(define (family-this-to-standard v)
|
|
(hash-ref family-ints v 70))
|
|
|
|
(define weight-ints
|
|
#hasheq((base . -1)
|
|
(light . 91)
|
|
(bold . 92)
|
|
(normal . 90)))
|
|
(define int-weights (invert weight-ints))
|
|
|
|
(define (weight-standard-to-this v)
|
|
(hash-ref int-weights v 'normal))
|
|
(define (weight-this-to-standard v)
|
|
(hash-ref weight-ints v 90))
|
|
|
|
(define style-ints
|
|
#hasheq((base . -1)
|
|
(italic . 93)
|
|
(slant . 94)
|
|
(normal . 90)))
|
|
(define int-styles (invert style-ints))
|
|
|
|
(define (style-standard-to-this v)
|
|
(hash-ref int-styles v 'normal))
|
|
(define (style-this-to-standard v)
|
|
(hash-ref style-ints v 90))
|
|
|
|
(define smoothing-ints
|
|
#hasheq((base . -1)
|
|
(partly-smoothed . 0)
|
|
(smoothed . 1)
|
|
(unsmoothed . 2)
|
|
(default . 3)))
|
|
(define int-smoothings (invert smoothing-ints))
|
|
|
|
(define (smoothing-standard-to-this v)
|
|
(hash-ref int-smoothings v 'default))
|
|
(define (smoothing-this-to-standard v)
|
|
(hash-ref smoothing-ints v 3))
|
|
|
|
(define align-ints
|
|
#hasheq((base . -1)
|
|
(top . 0)
|
|
(bottom . 1)
|
|
(center . 2)))
|
|
(define int-aligns (invert align-ints))
|
|
|
|
(define (align-standard-to-this v)
|
|
(hash-ref int-aligns v 'bottom))
|
|
(define (align-this-to-standard v)
|
|
(hash-ref align-ints v 1))
|
|
|
|
(define (read-styles-from-file style-list f overwritename? _list-id)
|
|
(let-boxes ([list-id 0])
|
|
(send f get list-id)
|
|
(set-box! _list-id list-id)
|
|
|
|
(or
|
|
(ormap (lambda (sll)
|
|
(and (= (style-list-link-list-id sll) list-id)
|
|
(style-list-link-style-list sll)))
|
|
(send f get-s-sll))
|
|
|
|
(let ([nms (send f get-exact)])
|
|
|
|
(let* ([map-vec (make-vector nms)]
|
|
[sll (make-style-list-link style-list
|
|
list-id
|
|
(send style-list basic-style)
|
|
nms
|
|
map-vec)])
|
|
(send f set-s-sll (cons sll (send f get-s-sll)))
|
|
|
|
(vector-set! map-vec 0 (send style-list basic-style))
|
|
|
|
(for ([i (in-range 1 nms)])
|
|
(let ([base-index (send f get-exact)])
|
|
|
|
(when (base-index . >= . i)
|
|
(error 'map-index-to-style "bad style index"))
|
|
|
|
(let ([name (bytes->string/utf-8 (send f get-bytes))])
|
|
(let ([is-join (send f get-exact)])
|
|
(if (positive? is-join)
|
|
(let ([shift-index (send f get-exact)])
|
|
(when (shift-index . >= . i)
|
|
(error 'map-index-to-style "bad shift-style index"))
|
|
(let ([js
|
|
(send style-list
|
|
find-or-create-join-style
|
|
(vector-ref map-vec base-index)
|
|
(vector-ref map-vec shift-index))])
|
|
(vector-set! map-vec i js)))
|
|
(let ([delta (new style-delta%)]
|
|
[get-float (lambda (f) (send f get-inexact))]
|
|
[get-int (lambda (f) (send f get-exact))])
|
|
(let ([fam (send f get-exact)])
|
|
|
|
(send delta set-family (family-standard-to-this fam))
|
|
(let ([name (bytes->string/utf-8 (send f get-bytes))])
|
|
(when (not (equal? name ""))
|
|
(send delta set-face (string->immutable-string name))))
|
|
|
|
(send delta set-size-mult (get-float f))
|
|
(send delta set-size-add (get-int f))
|
|
(send delta set-weight-on (weight-standard-to-this (get-int f)))
|
|
(send delta set-weight-off (weight-standard-to-this (get-int f)))
|
|
(send delta set-style-on (style-standard-to-this (get-int f)))
|
|
(send delta set-style-off (style-standard-to-this (get-int f)))
|
|
(unless (<= 1 (send f get-wxme-version) 4)
|
|
(send delta set-smoothing-on (smoothing-standard-to-this (get-int f)))
|
|
(send delta set-smoothing-off (smoothing-standard-to-this (get-int f))))
|
|
(send delta set-underlined-on (positive? (get-int f)))
|
|
(send delta set-underlined-off (positive? (get-int f)))
|
|
(unless (<= 1 (send f get-wxme-version) 5)
|
|
(send delta set-size-in-pixels-on (positive? (get-int f)))
|
|
(send delta set-size-in-pixels-off (positive? (get-int f))))
|
|
(unless (<= 1 (send f get-wxme-version) 2)
|
|
(send delta set-transparent-text-backing-on (positive? (get-int f)))
|
|
(send delta set-transparent-text-backing-off (positive? (get-int f))))
|
|
|
|
(let ([r (send f get-inexact)]
|
|
[g (send f get-inexact)]
|
|
[b (send f get-inexact)])
|
|
(send (send delta get-foreground-mult) set r g b))
|
|
(let ([r (send f get-inexact)]
|
|
[g (send f get-inexact)]
|
|
[b (send f get-inexact)])
|
|
(send (send delta get-background-mult) set r g b))
|
|
(let ([r (send f get-exact)]
|
|
[g (send f get-exact)]
|
|
[b (send f get-exact)])
|
|
(send (send delta get-foreground-add) set r g b))
|
|
(let ([r (send f get-exact)]
|
|
[g (send f get-exact)]
|
|
[b (send f get-exact)])
|
|
(send (send delta get-background-add) set r g b)
|
|
|
|
(when (<= 1 (send f get-wxme-version) 2)
|
|
(when (or (positive? r) (positive? g) (positive? b))
|
|
(send delta set-transparent-text-backing-off #t))))
|
|
|
|
(send delta set-alignment-on (align-standard-to-this (get-int f)))
|
|
(send delta set-alignment-off (align-standard-to-this (get-int f)))
|
|
|
|
(vector-set! map-vec i (send style-list find-or-create-style
|
|
(vector-ref map-vec base-index)
|
|
delta))))))
|
|
|
|
(when (not (equal? name ""))
|
|
(let ([ns
|
|
(if overwritename?
|
|
(send style-list replace-named-style name (vector-ref map-vec i))
|
|
(send style-list new-named-style name (vector-ref map-vec i)))])
|
|
(vector-set! map-vec i ns)))))))
|
|
style-list))))
|
|
|
|
(define (write-styles-to-file style-list f)
|
|
(or
|
|
(ormap (lambda (sll)
|
|
(and (eq? (style-list-link-style-list sll) style-list)
|
|
(begin
|
|
(send f put (style-list-link-list-id sll))
|
|
#t)))
|
|
(send f get-s-sll))
|
|
(let ([lid (send f get-s-style-count)])
|
|
(send f set-s-style-count (add1 lid))
|
|
|
|
(let ([sll (make-style-list-link style-list
|
|
lid
|
|
#f
|
|
#f
|
|
#f)])
|
|
(send f set-s-sll (cons sll (send f get-s-sll)))
|
|
|
|
(send f put lid)
|
|
|
|
(let ([count (send style-list number)])
|
|
(send f put count)
|
|
|
|
(for ([i (in-range 1 count)])
|
|
(let ([style (send style-list index-to-style i)])
|
|
|
|
(send f put (send style-list style-to-index (send style get-base-style)))
|
|
|
|
(send f put (let ([name (send style get-name)])
|
|
(if name
|
|
(string->bytes/utf-8 name)
|
|
#"")))
|
|
|
|
(if (send style is-join?)
|
|
(begin
|
|
(send f put 1)
|
|
(send f put (send style-list style-to-index (send style get-shift-style))))
|
|
(let ([delta (new style-delta%)])
|
|
(send style get-delta delta)
|
|
|
|
(send f put 0)
|
|
|
|
(send f put (family-this-to-standard (style-delta-family delta)))
|
|
(send f put (let ([face (style-delta-face delta)])
|
|
(if face
|
|
(string->bytes/utf-8 face)
|
|
#"")))
|
|
|
|
(send f put (style-delta-size-mult delta))
|
|
(send f put (style-delta-size-add delta))
|
|
(send f put (weight-this-to-standard (style-delta-weight-on delta)))
|
|
(send f put (weight-this-to-standard (style-delta-weight-off delta)))
|
|
(send f put (style-this-to-standard (style-delta-style-on delta)))
|
|
(send f put (style-this-to-standard (style-delta-style-off delta)))
|
|
(send f put (smoothing-this-to-standard (style-delta-smoothing-on delta)))
|
|
(send f put (smoothing-this-to-standard (style-delta-smoothing-off delta)))
|
|
(send f put (if (style-delta-underlined-on delta) 1 0))
|
|
(send f put (if (style-delta-underlined-off delta) 1 0))
|
|
(send f put (if (style-delta-size-in-pixels-on delta) 1 0))
|
|
(send f put (if (style-delta-size-in-pixels-off delta) 1 0))
|
|
(send f put (if (style-delta-transparent-text-backing-on delta) 1 0))
|
|
(send f put (if (style-delta-transparent-text-backing-off delta) 1 0))
|
|
|
|
(let-boxes ([r 0.0][g 0.0][b 0.0])
|
|
(send (style-delta-foreground-mult delta) get r g b)
|
|
(send f put r) (send f put g) (send f put b))
|
|
(let-boxes ([r 0.0][g 0.0][b 0.0])
|
|
(send (style-delta-background-mult delta) get r g b)
|
|
(send f put r) (send f put g) (send f put b))
|
|
(let-boxes ([r 0][g 0][b 0])
|
|
(send (style-delta-foreground-add delta) get r g b)
|
|
(send f put r) (send f put g) (send f put b))
|
|
(let-boxes ([r 0][g 0][b 0])
|
|
(send (style-delta-background-add delta) get r g b)
|
|
(send f put r) (send f put g) (send f put b))
|
|
|
|
(send f put (align-this-to-standard (style-delta-alignment-on delta)))
|
|
(send f put (align-this-to-standard (style-delta-alignment-off delta)))))))
|
|
|
|
#t)))))
|