#lang racket/base

(require racket/class
         racket/list
         racket/file
         racket/path
         (for-syntax racket/base)
         (prefix-in wx: "kernel.rkt")
         (prefix-in wx: racket/snip/private/style)
         (prefix-in wx: racket/snip/private/snip)
         (prefix-in wx: "wxme/keymap.rkt")
         (prefix-in wx: "wxme/editor.rkt")
         (prefix-in wx: "wxme/text.rkt")
         (prefix-in wx: "wxme/pasteboard.rkt")
         (prefix-in wx: "wxme/editor-snip.rkt")
         (prefix-in wx: (only-in "wxme/cycle.rkt"
                                 set-extended-editor-snip%!
                                 set-extended-text%!
                                 set-extended-pasteboard%!))
         "seqcontract.rkt"
         "lock.rkt"
         "check.rkt"
         "const.rkt"
         "helper.rkt"
         "cycle.rkt"
         "wx.rkt"
         "wxtop.rkt"
         "wxitem.rkt"
         "wxcanvas.rkt"
         "mrwindow.rkt"
         "mrtop.rkt"
         "mrcanvas.rkt"
         "mrpopup.rkt"
         "mrmenuintf.rkt"
         "mrmenu.rkt")

(provide editor<%>
         text%
         pasteboard%
         editor-snip%
         current-text-keymap-initializer
         append-editor-operation-menu-items
         append-editor-font-menu-items)

(define editor<%>
  (interface (wx:editor<%>)
    get-canvases
    get-active-canvas set-active-canvas
    get-canvas
    add-canvas remove-canvas
    auto-wrap get-max-view-size
    save-file))

(define-local-member-name
  -format-filter
  -format-filter/save
  -get-current-format
  -get-file-format
  -set-file-format
  -set-position
  -set-format)

(define (check-format who format)
  (unless (memq format '(guess standard text text-force-cr same copy))
    (raise-argument-error (who->name who)
                          "(or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)"
                          format)))

(define-syntax (augmentize stx)
  (syntax-case stx ()
    [(_ (result id arg ...) ...)
     #'(begin
         (define/overment (id arg ...)
           (and (super id arg ...)
                (inner result id arg ...)))
         ...)]))

(define (make-editor-buffer% % can-wrap? get-editor%)
                                        ; >>> This class is instantiated directly by the end-user <<<
  (class* % (editor<%> internal-editor<%>)
    (init-rest args)
    (rename-super [super-get-view-size get-view-size]
                  [super-begin-edit-sequence begin-edit-sequence]
                  [super-end-edit-sequence end-edit-sequence]
                  [super-insert-port insert-port]
                  [super-save-port save-port]
                  [super-erase erase]
                  [super-clear-undos clear-undos]
                  [super-get-load-overwrites-styles get-load-overwrites-styles]
                  [super-get-filename get-filename])
    (inherit get-max-width set-max-width get-admin
             get-keymap get-style-list
             set-modified set-filename
             get-file put-file
             get-max-undo-history)
    (define canvases null)
    (define active-canvas #f)
    (define auto-set-wrap? #f)
    (define use-text-mode? #t)
    (private*
     [max-view-size
      (lambda ()
        (let ([wb (box 0)]
              [hb (box 0)])
          (super-get-view-size wb hb)
          (unless (or (null? canvases) (null? (cdr canvases)))
            (for-each
             (lambda (canvas)
               (send canvas call-as-primary-owner
                     (lambda ()
                       (let ([wb2 (box 0)]
                             [hb2 (box 0)])
                         (super-get-view-size wb2 hb2)
                         (set-box! wb (max (unbox wb) (unbox wb2)))
                         (set-box! hb (max (unbox hb) (unbox hb2)))))))
             canvases))
          (values (unbox wb) (unbox hb))))])
    (public*
     [-format-filter (lambda (f) f)]
     [-format-filter/save (lambda (f) f)]
     [-set-file-format (lambda (f) (void))]
     [-set-position (lambda () (void))]
     [-get-file-format (lambda () 'standard)])

    (override*
     [insert-file
      (lambda (file [format 'guess] [show-errors? #t])
        (let ([who '(method editor<%> insert-file)])
          (check-path who file)
          (check-format who format))
        (do-load-file file format #f))]

     [load-file
      (lambda ([file #f] [format 'guess] [show-errors? #t])
        (do-load-file file format #t))])

    (public*
     [use-file-text-mode
      (case-lambda
        [() use-text-mode?]
        [(v?) (set! use-text-mode? (and v? #t))])])

    (private*
     [do-load-file
      (lambda (file format load?)
        (let ([who '(method editor<%> load-file)])
          (unless (equal? file "")
            (check-path/false who file))
          (check-format who format))
        (let* ([temp-filename?-box (box #f)]
               [old-filename (super-get-filename temp-filename?-box)])
          (let* ([file (cond
                        [(or (not (path-string? file))
                             (equal? file ""))
                         (if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
                             (let ([path (if old-filename
                                             (path-only old-filename)
                                             #f)])
                               (get-file path))
                             old-filename)]
                        [(path? file) file]
                        [else (string->path file)])])
            (and
             file
             (or (not load?)
                 (can-load-file? file (-format-filter format)))
             (begin
               (or (not load?)
                   (on-load-file file (-format-filter format)))
               (let ([port #f]
                     [finished? #f])
                 (dynamic-wind
                   void
                   (lambda ()
                     (set! port (open-input-file file))
                     (wx:begin-busy-cursor)
                     (super-begin-edit-sequence)
                     (dynamic-wind
                       void
                       (lambda ()
                         (when load?
                           (super-erase)
                           (unless (and (not (unbox temp-filename?-box))
                                        (equal? file old-filename))
                             (set-filename file #f)))
                         (let ([format (if (eq? format 'same)
                                           (-get-file-format)
                                           format)])
                           (let ([new-format
                                  (with-handlers ([values (lambda (x)
                                                            (set-filename #f #f)
                                                            (raise x))])
                                    (super-insert-port port
                                                       (-format-filter format)
                                                       (and load?
                                                            (super-get-load-overwrites-styles))))])
                             (close-input-port port) ; close as soon as possible
                             (when load?
                               (-set-file-format new-format)
                               (-set-position))))) ; text% only
                       (lambda ()
                         (super-end-edit-sequence)
                         (wx:end-busy-cursor)))
                     (when load?
                       (super-clear-undos)
                       (set-modified #f))
                     (set! finished? #t)
                     #t)
                   (lambda ()
                     ;; In case it wasn't closed before:
                     (when port (close-input-port port))
                     (when load?
                       (after-load-file finished?))))))))))])
    (public*
     [save-file
      (lambda ([file #f] [format 'same] [show-errors? #t])
        (let ([who '(method editor<%> save-file)])
          (unless (equal? file "")
            (check-path/false who file))
          (check-format who format))
        (let* ([temp-filename?-box (box #f)]
               [old-filename (super-get-filename temp-filename?-box)])
          (let* ([file (cond
                        [(or (not (path-string? file))
                             (equal? file ""))
                         (if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
                             (let ([path (if old-filename
                                             (path-only old-filename)
                                             #f)])
                               (put-file path (and old-filename
                                                   (file-name-from-path old-filename))))
                             old-filename)]
                        [(path? file) file]
                        [else (string->path file)])]
                 [f-format (-format-filter/save format)])
            (and
             file
             (can-save-file? file f-format)
             (begin
               (on-save-file file f-format)
               (let* ([actual-format (if (memq f-format '(copy same))
                                         (-get-file-format)
                                         f-format)]
                      [text? (memq actual-format '(text text-force-cr))]
                      [text-mode? (and text? use-text-mode?)])
                 (let ([port #f]
                       [finished? #f])
                   (dynamic-wind
                     void
                     (lambda ()
                       (set! port (open-output-file file
                                                    #:mode (if text-mode? 'text 'binary)
                                                    #:exists 'truncate/replace))
                       (wx:file-creator-and-type file #"mReD" (if text? #"TEXT" #"WXME"))
                       (wx:begin-busy-cursor)
                       (dynamic-wind
                         void
                         (lambda ()
                           (super-save-port port format #t)
                           (close-output-port port)     ; close as soon as possible
                           (unless (or (eq? format 'copy)
                                       (and (not (unbox temp-filename?-box))
                                            (equal? file old-filename)))
                             (set-filename file #f))
                           (unless (eq? format 'copy)
                             (-set-file-format actual-format))) ; text% only
                         (lambda ()
                           (wx:end-busy-cursor)))
                       (unless (eq? format 'copy)
                         (set-modified #f))
                       (set! finished? #t)
                       #t)
                     (lambda ()
                       ;; In case it wasn't closed before:
                       (when port (close-output-port port))
                       (after-save-file finished?))))))))))])

    (public*
     [get-canvases (entry-point (lambda () (map wx->mred canvases)))]
     [get-active-canvas (entry-point (lambda () (and active-canvas (wx->mred active-canvas))))]
     [get-canvas
      (entry-point
       (lambda ()
         (let ([c (or active-canvas
                      (and (not (null? canvases))
                           (car canvases)))])
           (and c (wx->mred c)))))]
     [set-active-canvas
      (entry-point
       (lambda (new-canvas)
         (check-instance '(method editor<%> set-active-canvas) editor-canvas% 'editor-canvas% #t new-canvas)
         (set! active-canvas (mred->wx new-canvas))))]

     [add-canvas
      (entry-point
       (lambda (new-canvas)
         (check-instance '(method editor<%> add-canvas) editor-canvas% 'editor-canvas% #f new-canvas)
         (let ([new-canvas (mred->wx new-canvas)])
           (unless (memq new-canvas canvases)
             (set! canvases (cons new-canvas canvases))))))]

     [remove-canvas
      (entry-point
       (lambda (old-canvas)
         (check-instance '(method editor<%> remove-canvas) editor-canvas% 'editor-canvas% #f old-canvas)
         (let ([old-canvas (mred->wx old-canvas)])
           (when (eq? old-canvas active-canvas)
             (set! active-canvas #f))
           (set! canvases (remq old-canvas canvases)))))]

     [auto-wrap (case-lambda
                  [() auto-set-wrap?]
                  [(on?) (as-entry
                          (lambda ()
                            (set! auto-set-wrap? (and on? #t))
                            (as-exit
                             (lambda ()
                               (if on?
                                   (on-display-size)
                                   (set-max-width 'none))))))])]
     [get-max-view-size (entry-point (lambda () (max-view-size)))])
    (override*
     [copy-self
      (lambda () (let ([e (make-object (get-editor%))])
                   (copy-self-to e)
                   e))]
     [copy-self-to
      (lambda (e)
        (super copy-self-to e)
        (send e auto-wrap auto-set-wrap?))])

    (overment*
     [on-display-size
      (entry-point
       (lambda ()
         (as-exit (lambda () (super on-display-size)))
         (when (as-exit (lambda () (get-admin)))
           (when (and can-wrap? auto-set-wrap?)
             (let-values ([(current-width) (as-exit (lambda () (get-max-width)))]
                          [(new-width new-height) (max-view-size)])
               (when (and (not (equal? current-width new-width))
                          (< 0 new-width))
                 (as-exit (lambda () (set-max-width new-width)))))))
         (as-exit (lambda () (inner (void) on-display-size)))))])

    (augmentize ((void) on-change)
                ((void) on-snip-modified snip x)
                (#t can-save-file? p t)
                ((void) on-save-file p t)
                ((void) after-save-file t)
                (#t can-load-file? p t)
                ((void) on-load-file p t)
                ((void) after-load-file t)
                ((void) on-edit-sequence)
                ((void) after-edit-sequence))

    (private*
     [sp (lambda (x y z f b? eps?)
           ;; let super method report z errors:
           (let ([zok? (memq z '(standard postscript))])
             (when zok?
               (check-top-level-parent/false '(method editor<%> print) f))
             (let ([p (and zok? f (mred->wx f))])
               (as-exit (lambda () (super print x y z p b? eps?))))))])

    (override*
     [print
      (entry-point
       (case-lambda
         [() (sp #t #t 'standard #f #t #f)]
         [(x) (sp x #t 'standard #f #t #f)]
         [(x y) (sp x y 'standard #f #t #f)]
         [(x y z) (sp x y z #f #t #f)]
         [(x y z f) (sp x y z f #t #f)]
         [(x y z f b?) (sp x y z f b? #f)]
         [(x y z f b? eps?) (sp x y z f b? eps?)]))]

     [on-new-box
      (entry-point
       (lambda (type)
         (unless (memq type '(text pasteboard))
           (raise-argument-error (who->name '(method editor<%> on-new-box)) "(or/c 'text 'pasteboard)" type))
         (make-object editor-snip%
                      (let ([e (make-object (cond
                                             [(eq? type 'pasteboard) pasteboard%]
                                             [else text%]))])
                        (send e set-keymap (get-keymap))
                        (send e set-style-list (get-style-list))
                        (send e set-max-undo-history (get-max-undo-history))
                        e))))])

    (apply super-make-object args)))

(define text%
  (class (lock-contract-mixin
          (es-contract-mixin
           (make-editor-buffer% wx:text% #t  (lambda () text%))))
    (init [line-spacing 1.0]
          [tab-stops null]
          [(aw? auto-wrap) #f])
    (rename-super [super-get-file-format get-file-format]
                  [super-set-file-format set-file-format]
                  [super-set-position set-position]
                  [super-auto-wrap auto-wrap])
    (override*
     [-get-file-format (lambda ()
                         (super-get-file-format))]
     [-set-file-format (lambda (format)
                         (super-set-file-format format))]
     [-set-position (lambda ()
                      (super-set-position 0 0))])

    (augmentize (#t can-insert? s e)
                ((void) on-insert s e)
                ((void) after-insert s e)
                (#t can-delete? s e)
                ((void) on-delete s e)
                ((void) after-delete s e)
                (#t can-change-style? s e)
                ((void) on-change-style s e)
                ((void) after-change-style s e)
                ((void) after-set-position)
                (#t can-set-size-constraint?)
                ((void) on-set-size-constraint)
                ((void) after-set-size-constraint)
                ((void) after-split-snip s)
                ((void) after-merge-snips s)
                ((void) on-reflow))

    (super-make-object line-spacing tab-stops)
    (when aw?
      (super-auto-wrap #t))))

(define pasteboard%
  (class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%)))
    (override*
     [-format-filter (lambda (f) 'standard)]
     [-format-filter/save (lambda (f) (if (eq? f 'copy)
                                          f
                                          'standard))])
    (augmentize (#t can-insert? s s2 x y)
                ((void) on-insert s s2 x y)
                ((void) after-insert s s2 x y)
                (#t can-delete? s)
                ((void) on-delete s)
                ((void) after-delete s)
                (#t can-move-to? s x y ?)
                ((void) on-move-to s x y ?)
                ((void) after-move-to s x y ?)
                (#t can-resize? s x y)
                ((void) on-resize s x y)
                ((void) after-resize s x y ?)
                (#t can-reorder? s s2 ?)
                ((void) on-reorder s s2 ?)
                ((void) after-reorder s s2 ?)
                (#t can-select? s ?)
                ((void) on-select s ?)
                ((void) after-select s ?)

                (#t can-interactive-move? e)
                ((void) on-interactive-move e)
                ((void) after-interactive-move e)
                (#t can-interactive-resize? s)
                ((void) on-interactive-resize s)
                ((void) after-interactive-resize s))
    (super-new)))

(define editor-snip%
  (class wx:editor-snip% (init [editor #f]
                               [with-border? #t]
                               [left-margin 5]
                               [top-margin 5]
                               [right-margin 5]
                               [bottom-margin 5]
                               [left-inset 1]
                               [top-inset 1]
                               [right-inset 1]
                               [bottom-inset 1]
                               [min-width 'none]
                               [max-width 'none]
                               [min-height 'none]
                               [max-height 'none])
    (super-make-object (or editor (make-object text%))
                       with-border?
                       left-margin
                       top-margin
                       right-margin
                       bottom-margin
                       left-inset
                       top-inset
                       right-inset
                       bottom-inset
                       min-width
                       max-width
                       min-height
                       max-height)))

(wx:set-extended-editor-snip%! editor-snip%)
(wx:set-extended-text%! text%)
(wx:set-extended-pasteboard%! pasteboard%)

;; ----------------------- Keymap ----------------------------------------

(define std-keymap (make-object wx:keymap%))

(let* ([k std-keymap]
       [mouse-paste (lambda (edit event)
                      (when (send event button-down?)
                        (cond
                         [(is-a? edit wx:text%)
                          (let ([x-box (box (send event get-x))]
                                [y-box (box (send event get-y))]
                                [eol-box (box #f)])
                            (send edit global-to-local x-box y-box)
                            (let ([click-pos (send edit find-position
                                                   (unbox x-box)
                                                   (unbox y-box)
                                                   eol-box)])
                              (send edit set-position click-pos)))]
                         [else (void)])
                        (send edit paste-x-selection)))]
       [mouse-popup-menu (lambda (edit event)
                           (when (send event button-up?)
                             (let ([a (send edit get-admin)])
                               (when a
                                 (let ([m (make-object popup-menu%)])
                                   (append-editor-operation-menu-items m)
                                   ;; Remove shortcut indicators (because they might not be correct)
                                   (for-each
                                    (lambda (i)
                                      (when (is-a? i selectable-menu-item<%>)
                                        (send i set-shortcut #f)))
                                    (send m get-items))
                                   (let-values ([(x y) (send edit
                                                             dc-location-to-editor-location
                                                             (send event get-x)
                                                             (send event get-y))])
                                     (send a popup-menu m (+ x 5) (+ y 5))))))))])
  (wx:add-text-keymap-functions k)
  (send k add-function "mouse-paste" mouse-paste)
  (send k add-function "mouse-popup-menu" mouse-popup-menu)
  (map
   (lambda (key func) (send k map-function key func))
   (append
    (case (system-type)
      [(windows) '(":c:c" ":c:x" ":c:v" ":c:k" ":c:z" ":c:a")]
      [(macos macosx) '(":d:c" ":d:x" ":d:v" ":d:k" ":d:z" ":d:a")]
      [(unix) '(":m:w" ":c:w" ":c:y" ":c:k" ":c:s:_" ":m:a")])
    '(":middlebutton"))
   '("copy-clipboard" "cut-clipboard" "paste-clipboard" "delete-to-end-of-line"
     "undo" "select-all" "mouse-paste"))
  (send k map-function ":rightbuttonseq" "mouse-popup-menu")
  (when (eq? (system-type) 'unix)
    (send k map-function ":c:a" "beginning-of-line")
    (send k map-function ":c:e" "end-of-line")))

(define (check-installer who)
  (lambda (p)
    (unless (and (procedure? p)
                 (procedure-arity-includes? p 1))
      (raise-argument-error who
                            "(procedure-arity-includes/c 1)"
                            p))
    p))

(define current-text-keymap-initializer
  (make-parameter (let ([default-text-keymap-initializer
                          (lambda (k)
                            (check-instance 'default-text-keymap-initializer wx:keymap% 'keymap% #f k)
                            ;; Level of indirection to protect std-keymap:
                            (let ([naya (make-object wx:keymap%)])
                              (send naya chain-to-keymap std-keymap #f)
                              (send k chain-to-keymap naya #f)))])
                    default-text-keymap-initializer)
                  (check-installer 'default-text-keymap-initializer)))

(define (find-item-editor item)
  (let ([o (let loop ([i item])
             (let ([p (send i get-parent)])
               (cond
                [(not p) #f]
                [(is-a? p popup-menu%)
                 (let ([p (send p get-popup-target)])
                   (if (is-a? p window<%>)
                       (let ([f (send p get-top-level-window)])
                         (and f (send f get-edit-target-object)))
                       p))]
                [(is-a? p menu%) (loop p)]
                [else (let ([f (send p get-frame)])
                        (and f (send f get-edit-target-object)))])))])
    (and (is-a? o wx:editor<%>)
         o)))

;; ------------------------- Menus ----------------------------------------

(define (append-editor-operation-menu-items m
                                            [text-only? #t]
                                            #:popup-position [popup-position #f])
  (unless (or (not popup-position)
              (and (list? popup-position)
                   (= 2 (length popup-position))
                   (is-a? (list-ref popup-position 0) text%)
                   (exact-nonnegative-integer? (list-ref popup-position 1))))
    (raise-argument-error 'append-editor-operation-menu-items
                          (format "~s" '(or/c #f (list/c (is-a?/c text%) exact-nonnegative-integer?)))
                          popup-position))
  (menu-parent-only 'append-editor-operation-menu-items m)
  (let* ([mk (lambda (name key op [special-case? (λ () #f)] [special-go void])
               (make-object (class menu-item%
                              (inherit enable)
                              (define/override (on-demand)
                                (let ([o (find-item-editor this)])
                                  (enable (and o
                                               (or (send o can-do-edit-operation? op)
                                                   (special-case?))))))
                              (super-make-object
                               name m
                               (lambda (i e)
                                 (let* ([o (find-item-editor i)])
                                   (and o
                                        (if (special-case?)
                                            (special-go)
                                            (send o do-edit-operation op)))))
                               key))))]
         [mk-sep (lambda () (make-object separator-menu-item% m))])
    (define (special-case?)
      (cond
        [popup-position
         (define snp (send (list-ref popup-position 0) find-snip 
                           (list-ref popup-position 1)
                           'after-or-none))
         (and snp (not (is-a? snp wx:string-snip%)))]
        [else
         #f]))
    (define (copy-special-go)
      (send (list-ref popup-position 0)
            copy #f 0 
            (list-ref popup-position 1)
            (+ (list-ref popup-position 1) 1)))
    (define (cut-special-go)
      (send (list-ref popup-position 0)
            cut #f 0 
            (list-ref popup-position 1)
            (+ (list-ref popup-position 1) 1)))
    (mk "&Undo" #\z 'undo)
    (mk "Redo" #f 'redo)
    (mk-sep)
    (mk "&Copy" #\c 'copy special-case? copy-special-go)
    (mk "Cu&t" #\x 'cut special-case? cut-special-go)
    (mk "&Paste" #\v 'paste)
    (if (eq? (system-type) 'windows)
        (mk "Delete" #f 'clear)
        (mk "Clear" #f 'clear))
    (mk "Select &All" #\a 'select-all)
    (unless text-only?
      (mk-sep)
      (mk "Insert Text Box" #f 'insert-text-box)
      (mk "Insert Pasteboard Box" #f 'insert-pasteboard-box)
      (mk "Insert Image..." #f 'insert-image))
    (void)))

(define (append-editor-font-menu-items m)
  (menu-parent-only 'append-editor-font-menu-items m)
  (let ([mk (lambda (name m cb)
              (make-object menu-item% name m
                           (lambda (i e)
                             (let* ([o (find-item-editor i)])
                               (and o (cb o))))))]
        [mk-sep (lambda (m) (make-object separator-menu-item% m))]
        [mk-menu (lambda (name) (make-object menu% name m))])
    (let ([family (mk-menu "Font")]
          [size (mk-menu "Size")]
          [style (mk-menu "Style")]
          [weight (mk-menu "Weight")]
          [underline (mk-menu "Underline")]
          [alignment (mk-menu "Alignment")]
          [color (mk-menu "Color")]
          [background (mk-menu "Background")])

                                        ; Font menu
      (for-each (lambda (l f)
                  (mk l family
                      (lambda (e)
                        (send e change-style (make-object wx:style-delta% 'change-family f)))))
                '("Standard" "Decorative" "Roman" "Script" "Swiss" "Fixed" "Symbol")
                '(default decorative roman script swiss modern symbol))
      (mk-sep family)
      (mk "Choose..." family (lambda (e) (let ([f ((get-get-font-from-user))])
                                           (when f
                                             (send e change-style (font->delta f))))))

                                        ; Size menu
      (let ([bigger (make-object menu% "Bigger" size)]
            [smaller (make-object menu% "Smaller" size)]
            [add-change-size
             (lambda (m ls dss xss)
               (for-each (lambda (l ds xs)
                           (mk l m (lambda (e)
                                     (let ([d (make-object wx:style-delta%)])
                                       (send d set-size-add ds)
                                       (send d set-size-mult xs)
                                       (send e change-style d)))))
                         ls dss xss))])
        (add-change-size bigger
                         '("+1" "+2" "+4" "+8" "+16" "+32")
                         '(1 2 4 8 16 32)
                         '(1 1 1 1 1  1))
        (mk-sep bigger)
        (add-change-size bigger
                         '("x2" "x3" "x4" "x5")
                         '(0    0    0    0)
                         '(2    3    4    5))

        (add-change-size smaller
                         '("-1" "-2" "-4" "-8" "-16" "-32")
                         '(1 -2 -4 -8 -16 -32)
                         '(1 1   1  1  1  1))
        (mk-sep smaller)
        (add-change-size smaller
                         '("/2" "/3" "/5" "/5")
                         '(0    0    0    0)
                         '(#i1/2 #i1/3 #i1/4 #i1/5))

        (for-each (lambda (s)
                    (mk (number->string s) size (lambda (e)
                                                  (let ([d (make-object wx:style-delta%)])
                                                    (send d set-size-add s)
                                                    (send d set-size-mult 0)
                                                    (send e change-style d)))))
                  '(9 10 12 14 16 24 32 48)))


      (let ([mk-cg (lambda (cmd arg)
                     (lambda (e) (send e change-style (make-object wx:style-delta% cmd arg))))])

                                        ; Style
        (for-each (lambda (name s)
                    (mk name style (mk-cg 'change-style s)))
                  '("Normal" "Italic" "Slant")
                  '(normal italic slant))

                                        ; Weight
        (for-each (lambda (name s)
                    (mk name weight (mk-cg 'change-weight s)))
                  '("Normal" "Bold" "Light")
                  '(normal bold light))

                                        ; Underline
        (mk "No Underline" underline (mk-cg 'change-underline #f))
        (mk "Underline" underline (mk-cg 'change-underline #t))
        (mk "Toggle" underline (lambda (e) (send e change-style (make-object wx:style-delta% 'change-toggle-underline))))

                                        ; Alignment
        (for-each (lambda (name s)
                    (mk name alignment (mk-cg 'change-alignment s)))
                  '("Top" "Center" "Bottom")
                  '(top center bottom))

        (let ([colors '("Black" "White" "Red" "Orange" "Yellow" "Green" "Blue" "Purple" "Cyan" "Magenta" "Gray")])

                                        ; Colors
          (for-each (lambda (c)
                      (mk c color (lambda (e) (let ([d (make-object wx:style-delta%)])
                                                (send d set-delta-foreground c)
                                                (send e change-style d)))))
                    colors)

                                        ; Background
          (mk "Transparent" background (lambda (e) (let ([d (make-object wx:style-delta%)])
                                                     (send d set-transparent-text-backing-on #t)
                                                     (send e change-style d))))
          (for-each (lambda (c)
                      (mk c background (lambda (e) (let ([d (make-object wx:style-delta%)])
                                                     (send d set-delta-background c)
                                                     (send e change-style d)))))
                    colors))))))
