#lang racket/unit

#|

The color scheme library should probalby move into mrlib
so that other mrlib libraries can depend on it without
pulling in the framework.

I'm not sure how to do that wrt to the editor style list,
tho, as the sharing of that is pretty key to how this works.

Notably the syntax snips don't quite work currently; when you
open them and then switch from dark to light mode, the label
on top's background stays in the wrong mode.
  
|#

  (require racket/class
           racket/gui/base
           string-constants
           racket/match
           racket/contract/base
           racket/set
           setup/getinfo
           setup/collects
           string-constants
           racket/pretty
           mrlib/panel-wob
           "../preferences.rkt"
           "sig.rkt"
           "srcloc-panel.rkt"
           (prefix-in wob-cs: "wob-color-scheme.rkt")
           )
  
  (import [prefix preferences: framework:preferences^]
          [prefix editor: framework:editor^]
          [prefix canvas: framework:canvas^]
          [prefix racket: framework:racket^]
          [prefix color: framework:color^])
  (export framework:color-prefs/int^)
  (init-depend framework:editor^)
  
  (define standard-style-list-text% (editor:standard-style-list-mixin text%))
  
  ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
  ;; constructs a panel containg controls to configure the preferences panel.
  (define (build-color-selection-panel parent pref-sym style-name example-text 
                                       #:background? [background? #f])
    (define (get-from-pref-sym)
      (if (set-member? known-style-names pref-sym)
          (lookup-in-color-scheme pref-sym)
          (preferences:get pref-sym)))
    (define (set-via-pref-sym delta) 
      (if (set-member? known-style-names pref-sym)
          (set-in-color-scheme pref-sym delta)
          (preferences:set pref-sym delta)))
    (define (add-pref-sym-callback f) 
      (if (set-member? known-style-names pref-sym)
          (register-color-scheme-entry-change-callback pref-sym f)
          (preferences:add-callback pref-sym (λ (p sd) (f sd)))))
    (define (update-style-delta func)
      (let ([working-delta (new style-delta%)])
        (send working-delta copy (get-from-pref-sym))
        (func working-delta)
        (set-via-pref-sym working-delta)))
    (define hp (new-horizontal-panel%
                    [parent parent]
                    [style '(border)]
                    [alignment '(center top)]
                    [stretchable-height #f]))
    
    (define e (new (class standard-style-list-text%
                     (inherit change-style get-style-list)
                     (define/augment (after-insert pos offset)
                       (inner (void) after-insert pos offset)
                       (let ([style (send (get-style-list)
                                          find-named-style
                                          style-name)])
                         (change-style style pos (+ pos offset) #f)))
                     (super-new))))
    (define c (new canvas:color%
                   [parent hp]
                   [min-width 150]
                   [editor e]
                   [stretchable-height #t]
                   [style '(hide-hscroll hide-vscroll)]))
    
    (define (make-check name on off)
      (let* ([c (λ (check command)
                  (if (send check get-value)
                      (update-style-delta on)
                      (update-style-delta off)))]
             [check (new check-box% 
                         [label name]
                         [parent hp]
                         [callback c])])
        check))
    
    (define slant-check
      (make-check (string-constant cs-italic)
                  (λ (delta)
                    (send delta set-style-on 'italic)
                    (send delta set-style-off 'base))
                  (λ (delta)
                    (send delta set-style-on 'normal)
                    (send delta set-style-off 'base))))
    (define bold-check
      (make-check (string-constant cs-bold)
                  (λ (delta)
                    (send delta set-weight-on 'bold)
                    (send delta set-weight-off 'base))
                  (λ (delta)
                    (send delta set-weight-on 'normal)
                    (send delta set-weight-off 'base))))
    (define underline-check
      (make-check (string-constant cs-underline)
                  (λ (delta)
                    (send delta set-underlined-on #t)
                    (send delta set-underlined-off #f))
                  (λ (delta)
                    (send delta set-underlined-off #f)
                    (send delta set-underlined-on #f))))
    
    (define smoothing-options
      '(default
         partly-smoothed
         smoothed
         unsmoothed))
    (define smoothing-option-strings
      (list (string-constant cs-smoothing-default)
            (string-constant cs-smoothing-partial)
            (string-constant cs-smoothing-full)
            (string-constant cs-smoothing-none)))
    
    (define (smoothing->index s)
      (let loop ([i 0]
                 [l smoothing-options])
        (cond
          [(null? l) 
           ;; if it is something strange or it is 'base, we go with 'default (which is 0)
           0]
          [else
           (if (eq? (car l) s)
               i
               (loop (+ i 1)
                     (cdr l)))])))
    
    (define smoothing-menu
      (new choice%
           [label #f]
           [parent hp]
           [choices smoothing-option-strings]
           [callback 
            (λ (c e)
              (update-style-delta
               (λ (delta)
                 (send delta set-smoothing-on 
                       (list-ref smoothing-options
                                 (send c get-selection))))))]))
    
    (define fore/back-panel
      (and background? 
           (new vertical-pane%
                [parent hp]
                [stretchable-width #f]
                [stretchable-height #f])))
    
    (define foreground-color-button
      (and (>= (get-display-depth) 8)
           (new button%
                [label (if background? 
                           (string-constant cs-foreground-color)
                           (string-constant cs-change-color))]
                [parent (if background? 
                            fore/back-panel
                            hp)]
                [callback
                 (λ (color-button evt)
                   (define pref (get-from-pref-sym))
                   (define orig-add (send pref get-foreground-add))
                   (define color
                     (make-object color%
                                  (send orig-add get-r)
                                  (send orig-add get-g)
                                  (send orig-add get-b)
                                  (send orig-add get-a)))
                   (define users-choice
                     (get-color-from-user
                      (format (string-constant syntax-coloring-choose-color) example-text)
                      (send color-button get-top-level-window)
                      color
                      '(alpha)))
                   (when users-choice
                     (update-style-delta
                      (λ (delta)
                        (send delta set-delta-foreground users-choice)))))])))

    (define background-color-button
      (and (>= (get-display-depth) 8)
           background?
           (new button%
                [label (string-constant cs-background-color)]
                [parent (if background? 
                            fore/back-panel
                            hp)]
                [callback
                 (λ (color-button evt)
                   (let* ([add (send (get-from-pref-sym) get-background-add)]
                          [color (make-object color%
                                   (send add get-r)
                                   (send add get-g)
                                   (send add get-b)
                                   (send add get-a))]
                          [users-choice
                           (get-color-from-user
                            (format (string-constant syntax-coloring-choose-color) example-text)
                            (send color-button get-top-level-window)
                            color
                            '(alpha))])
                     (when users-choice
                       (update-style-delta
                        (λ (delta)
                          (send delta set-delta-background users-choice))))))])))
    
    (define style (send (send e get-style-list) find-named-style style-name))
    
    (send c set-line-count 1)
    (send c allow-tab-exit #t)
    
    (send e insert example-text)
    (send e set-position 0)
    
    (send slant-check set-value (or (eq? (send style get-style) 'slant)
                                    (eq? (send style get-style) 'italic)))
    (send bold-check set-value (eq? (send style get-weight) 'bold))
    (send underline-check set-value (send style get-underlined))
    (send smoothing-menu set-selection (smoothing->index (send style get-smoothing)))
    
    (send hp reflow-container)
    (when (> (send c get-height) 50)
      (send c set-line-count #f)
      (send c min-height 50)
      (send c stretchable-height #f))
    
    (add-pref-sym-callback
     (λ (sd)
       (send slant-check set-value (or (equal? (send style get-style) 'slant)
                                       (equal? (send style get-style) 'italic)))
       (send bold-check set-value (equal? (send sd get-weight-on) 'bold))
       (send underline-check set-value (send sd get-underlined-on))
       (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
    (void))

(define (normalize-color-selection-button-widths parent)
  (send parent reflow-container)
  (define button-labels
    (list (string-constant cs-background-color)
          (string-constant cs-foreground-color)
          (string-constant cs-change-color)))
  (define buttons '())

  (let loop ([obj parent])
    (cond
      [(is-a? obj area-container<%>)
       (for ([child (in-list (send obj get-children))])
           (loop child))]
      [(is-a? obj button%)
       (when (member (send obj get-label)
                     button-labels)
         (set! buttons (cons obj buttons)))]))

  (define max-width
    (for/fold ([biggest 0])
              ([button (in-list buttons)])
      (max biggest (send button get-width))))
  (for ([button (in-list buttons)])
    (send button min-width max-width)))

  (define (add/mult-get c)
    (list (send c get-r)
          (send c get-g)
          (send c get-b)
          (send c get-a)))

  (define (add/mult-set c v)
    (send c set (car v) (cadr v) (caddr v) (cadddr v)))

  (define (avg x y z) (/ (+ x y z) 3))
  (define (pin-between lo x hi) (min (max lo x) hi))
  (define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255))
  
  (define (encoded-add-get a)
    ;; for historical reasons, the alpha component is
    ;; encoded in a combination of `add` and `mult`;
    ;; we just get the add part of the encoding here
    (let ([r (send a get-r)]
          [g (send a get-g)]
          [b (send a get-b)]
          [α (send a get-a)])
      (list 
       (to-byte (- 255 (* (- 255 r) α)))
       (to-byte (- 255 (* (- 255 g) α)))
       (to-byte (- 255 (* (- 255 b) α))))))
  
  (define (encoded-add-set m v)
    ;; still in encoded form, to be fixed up by `mult-set`
    (send m set (car v) (cadr v) (caddr v)))

  (define (encoded-mult-get m a)
    ;; encodes part of `a`; we can only represent
    ;; style deltas that fit into the encoding, which corresponds
    ;; to a `set-delta-foreground` or `set-delta-background`
    (let ([α (send a get-a)])
      (list (- 1 α) (- 1 α) (- 1 α))))

  (define (encoded-mult-set m a v)
    ;; updates both `m` and `a`, assuming that first part of
    ;; encoding has been installed in `a`:
    (let ([α (- 1 (pin-between 0
                               (avg (car v) (cadr v) (caddr v))
                               1))]
          [r (send a get-r)]
          [g (send a get-g)]
          [b (send a get-b)])
      (send m set 0.0 0.0 0.0 0.0)
      (if (zero? α)
          (send a set 0 0 0 0.0)
          (send a set
                (to-byte (- 255 (/ (- 255 r) α)))
                (to-byte (- 255 (/ (- 255 g) α)))
                (to-byte (- 255 (/ (- 255 b) α)))
                α))))
  
  (define style-delta-get/set
    (let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))]
          [lo4n (λ (x) (and (list? x) (= (length x) 4) (andmap number? x)))])
      (list (list (λ (x) (send x get-alignment-off))
                  (λ (x v) (send x set-alignment-off v))
                  (λ (x) (memq x '(base top center bottom))))
            
            (list (λ (x) (send x get-alignment-on))
                  (λ (x v) (send x set-alignment-on v))
                  (λ (x) (memq x '(base top center bottom))))
            
            ;; encoded form is replaced later by direct form, if present:
            (list (λ (x) (encoded-add-get (send x get-background-add)))
                  (λ (x v) (encoded-add-set (send x get-background-add) v))
                  lo3n)

            ;; encoded form is replaced later by direct form, if present:
            (list (λ (x) (encoded-mult-get (send x get-background-mult) (send x get-background-add)))
                  ;; setter relies on `add-set` running first:
                  (λ (x v) (encoded-mult-set (send x get-background-mult) (send x get-background-add) v))
                  lo3n)
            
            (list (λ (x) (send x get-face))
                  (λ (x v) (send x set-face v))
                  (λ (x) (or (string? x) (not x))))
            
            (list (λ (x) (send x get-family))
                  (λ (x v) (send x set-family v))
                  (λ (x) (memq x '(base default decorative roman script swiss modern symbol system))))
            
            ;; encoded form is replaced later by direct form, if present:
            (list (λ (x) (encoded-add-get (send x get-foreground-add)))
                  (λ (x v) (encoded-add-set (send x get-foreground-add) v))
                  lo3n)

            ;; encoded form is replaced later by direct form, if present:
            (list (λ (x) (encoded-mult-get (send x get-foreground-mult) (send x get-foreground-add)))
                  ;; setter relies on `add-set` running first:
                  (λ (x v) (encoded-mult-set (send x get-foreground-mult) (send x get-foreground-add) v))
                  lo3n)
            
            (list (λ (x) (send x get-size-add))
                  (λ (x v) (send x set-size-add v))
                  (λ (x) (and (integer? x) (exact? x) (<= 0 x 255))))
            
            (list (λ (x) (send x get-size-mult))
                  (λ (x v) (send x set-size-mult v))
                  (λ (x) (and (number? x) (real? x))))
            
            (list (λ (x) (send x get-style-off))
                  (λ (x v) (send x set-style-off v))
                  (λ (x) (memq x '(base normal italic slant))))
            
            (list (λ (x) (send x get-style-on))
                  (λ (x v) (send x set-style-on v))
                  (λ (x) (memq x '(base normal italic slant))))
            
            (list (λ (x) (send x get-underlined-off))
                  (λ (x v) (send x set-underlined-off v))
                  boolean?)
            
            (list (λ (x) (send x get-underlined-on))
                  (λ (x v) (send x set-underlined-on v))
                  boolean?)
            
            (list (λ (x) (send x get-weight-off))
                  (λ (x v) (send x set-weight-off v))
                  (λ (x) (memq x '(base normal bold light))))
            
            (list (λ (x) (send x get-weight-on))
                  (λ (x v) (send x set-weight-on v))
                  (λ (x) (memq x '(base normal bold light))))

            ;; replaces whatever is read through the encoded form:
            (list (λ (x) (add/mult-get (send x get-background-add)))
                  (λ (x v) (add/mult-set (send x get-background-add) v))
                  lo4n)
            (list (λ (x) (add/mult-get (send x get-background-mult)))
                  (λ (x v) (add/mult-set (send x get-background-mult) v))
                  lo4n)

            ;; replaces whatever is read through the encoded form:
            (list (λ (x) (add/mult-get (send x get-foreground-add)))
                  (λ (x v) (add/mult-set (send x get-foreground-add) v))
                  lo4n)
            (list (λ (x) (add/mult-get (send x get-foreground-mult)))
                  (λ (x v) (add/mult-set (send x get-foreground-mult) v))
                  lo4n))))
  
  (define (marshall-style-delta style)
    (map (λ (fs) ((car fs) style)) style-delta-get/set))
  
  (define (unmarshall-style-delta info)
    (let ([style (make-object style-delta%)])
      
      (when (list? info)
        (let loop ([style-delta-get/set style-delta-get/set]
                   [info info])
          (cond
            [(null? info) (void)]
            [(null? style-delta-get/set) (void)]
            [else (let ([v (car info)]
                        [fs (car style-delta-get/set)])
                    (when ((list-ref fs 2) v)
                      ((list-ref fs 1) style v))
                    (loop (cdr style-delta-get/set)
                          (cdr info)))])))
      
      style))

  (define (unmarshall-style-delta-with-background info)
    (define style (unmarshall-style-delta info))
    (send style set-transparent-text-backing-on #f)
    (send style set-transparent-text-backing-off #t)
    style)
  
  (define (make-style-delta color bold underline? italic? #:background [background #f])
    (define sd (make-object style-delta%))
    (send sd set-delta-foreground color)
    (cond
      [(equal? bold 'base)
       (send sd set-weight-on 'base)
       (send sd set-weight-off 'base)]
      [bold
       (send sd set-weight-on 'bold)
       (send sd set-weight-off 'base)]
      [else
       (send sd set-weight-on 'base)
       (send sd set-weight-off 'bold)])
    (send sd set-underlined-on underline?)
    (send sd set-underlined-off (not underline?))
    (cond
      [italic?
       (send sd set-style-on 'italic)
       (send sd set-style-off 'base)]
      [else
       (send sd set-style-on 'base)
       (send sd set-style-off 'italic)])
    (when background
      (send sd set-delta-background background))
    sd)
  
  (define (add-background-preferences-panel)
    (preferences:add-panel
     (list (string-constant preferences-colors)
           (string-constant background-color))
     (λ (parent)
       (let ([vp (new-vertical-panel% (parent parent) (alignment '(left top)))])
         (add-solid-color-config (string-constant background-color)
                                 vp
                                 'framework:basic-canvas-background)
         (add-solid-color-config (string-constant basic-gray-paren-match-color)
                                 vp
                                 'framework:paren-match-color)
         (build-text-foreground-selection-panel vp
                                                'framework:default-text-color
                                                (editor:get-default-color-style-name)
                                                (string-constant default-text-color))
         
         (build-text-foreground-selection-panel vp
                                                'framework:misspelled-text-color
                                                color:misspelled-text-color-style-name
                                                (string-constant misspelled-text-color))
         
         (let* ([choice (new choice% 
                             [label (string-constant parenthesis-color-scheme)]
                             [parent vp]
                             [choices (map (λ (x) (list-ref x 1)) 
                                           (color:get-parenthesis-colors-table))]
                             [callback
                              (λ (choice _)
                                (preferences:set 'framework:paren-color-scheme
                                                 (car (list-ref (color:get-parenthesis-colors-table)
                                                                (send choice get-selection)))))])]
                [update-choice
                 (lambda (v)
                   (send choice set-string-selection 
                         (cadr (or (assoc v (color:get-parenthesis-colors-table))
                                   (car (color:get-parenthesis-colors-table))))))])
           (preferences:add-callback 
            'framework:paren-color-scheme
            (λ (p v)
              (update-choice v)))
           (update-choice (preferences:get 'framework:paren-color-scheme)))))))
    
  (define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
    (define hp (new-horizontal-panel% 
                    (parent parent)
                    (style '(border))
                    (stretchable-height #f)))
    (define e (new (class standard-style-list-text%
                     (inherit change-style get-style-list)
                     (define/augment (after-insert pos offset)
                       (inner (void) after-insert pos offset)
                       (let ([style (send (get-style-list)
                                          find-named-style
                                          style-name)])
                         (change-style style pos (+ pos offset) #f)))
                     (super-new))))
    (define c (new canvas:color%
                   (parent hp)
                   (editor e)
                   (style '(hide-hscroll
                            hide-vscroll))))
    (define color-button
      (and (>= (get-display-depth) 8)
           (make-object button%
             (string-constant cs-change-color)
             hp
             (λ (color-button evt)
               (let ([users-choice
                      (get-color-from-user
                       (format (string-constant syntax-coloring-choose-color) example-text)
                       (send color-button get-top-level-window)
                       (lookup-in-color-scheme pref-sym)
                       '(alpha))])
                 (when users-choice
                   (set-in-color-scheme pref-sym users-choice)))))))
    (define style (send (send e get-style-list) find-named-style style-name))
    
    (send c set-line-count 1)
    (send c allow-tab-exit #t)
    
    (send e insert example-text)
    (send e set-position 0))
  
  (define (add-solid-color-config label parent pref-id)
    (define panel (new-vertical-panel% (parent parent) (stretchable-height #f)))
    (define hp (new-horizontal-panel% (parent panel) (stretchable-height #f)))
    (define msg (new message% (parent hp) (label label)))
    (define canvas
      (new canvas%
           (parent hp)
           (paint-callback
            (λ (c dc)
              (draw (lookup-in-color-scheme pref-id))))))
    (define (draw clr)
      (define dc (send canvas get-dc))
      (define-values (w h) (send canvas get-client-size))
      (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
      (send dc set-brush (if (preferences:get 'framework:white-on-black?)
                             "black"
                             "white")
            'solid)
      (send dc draw-rectangle 0 0 w h)
      (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
      (send dc draw-rectangle 0 0 w h))
    (define button
      (new button% 
           (label (string-constant cs-change-color))
           (parent hp)
           (callback
            (λ (x y)
              (define color (get-color-from-user
                             (string-constant choose-a-background-color)
                             (send hp get-top-level-window)
                             (lookup-in-color-scheme pref-id)
                             '(alpha)))
              (when color
                (set-in-color-scheme pref-id color))))))
    (register-color-scheme-entry-change-callback
     pref-id
     (λ (v) 
       ;; the pref should be updated on the next event callback
       (queue-callback (λ () (send canvas refresh)))))
    panel)

  ;; add-to-preferences-panel : string (vertical-panel -> void) -> void
  (define (add-to-preferences-panel panel-name func #:style [style '()])
    (preferences:add-panel
     (list (string-constant preferences-colors) panel-name)
     (λ (parent)
       (let ([panel (new-vertical-panel% (parent parent) [style style])])
         (func panel)
         panel))))
  
  (define (register-color-preference pref-name style-name color/sd 
                                     [white-on-black-color #f]
                                     [use-old-marshalling? #t]
                                     #:background [background #f])
    (let ([sd (cond 
                [(is-a? color/sd style-delta%)
                 color/sd]
                [else
                 (let ([sd (new style-delta%)])
                   (send sd set-delta-foreground color/sd)
                   sd)])])
      
      (when background
        (send sd set-delta-background background))
      
      (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))
      (when white-on-black-color
        (set! color-scheme-colors
              (cons (list pref-name
                          color/sd
                          (to-color white-on-black-color 'register-color-preference))
                    color-scheme-colors)))
      (preferences:set-un/marshall pref-name marshall-style-delta (if background
                                                                      unmarshall-style-delta-with-background
                                                                      unmarshall-style-delta))
      (preferences:add-callback pref-name
                                (λ (sym v)
                                  (editor:set-standard-style-list-delta style-name v)))
      (editor:set-standard-style-list-delta style-name (preferences:get pref-name))))
  
  (define color-scheme-colors '())
  
  (define (set-default/color-scheme pref-sym black-on-white white-on-black)
    (let ([bw-c (to-color black-on-white 'set-default/color-scheme)]
          [wb-c (to-color white-on-black 'set-default/color-scheme)])
      (set! color-scheme-colors
            (cons (list pref-sym bw-c wb-c)
                  color-scheme-colors))
      
      (preferences:set-default pref-sym bw-c (λ (x) (is-a? x color%)))
      (preferences:set-un/marshall 
       pref-sym
       (λ (clr) (list (send clr red) (send clr green) (send clr blue) (send clr alpha)))
       unmarshall-color)
      (void)))
  
(define (unmarshall-color lst)
  (match lst
    [(list (? byte? red) (? byte? green) (? byte? blue))
     ;; old prefs-- before there were no alpha components to color% objects
     ;; and so only r/g/b was saved.
     (make-object color% red green blue)]
    [(list (? byte? red) (? byte? green) (? byte? blue) (? (between/c 0 1) α))
     (make-object color% red green blue α)]
    [else #f]))

  (define (to-color c who)
    (cond
      [(is-a? c color%) c]
      [(is-a? c style-delta%)
       (let ([m (send c get-foreground-mult)])
         (unless (and (= 0 (send m get-r))
                      (= 0 (send m get-g))
                      (= 0 (send m get-b)))
           (error 'register-color-scheme
                  "expected a style delta with foreground-mult that is all zeros"))
         (let ([add (send c get-foreground-add)])
           (make-object color% 
             (send add get-r)
             (send add get-g)
             (send add get-b))))]
      [(string? c)
       (or (send the-color-database find-color c)
           (error who
                  "color not found in the-color-database\n  color: ~e"
                  c))]))
  
  (define (black-on-white) (do-colorization cadr))
  (define (white-on-black) (do-colorization caddr))
  (define (do-colorization sel)
    (for-each (λ (l) 
                (let* ([p (car l)]
                       [color (sel l)]
                       [old (preferences:get p)])
                  (cond
                    [(is-a? old color%)
                     (preferences:set p color)]
                    [(is-a? old style-delta%)
                     (send old set-delta-foreground color)
                     (preferences:set p old)])))
              color-scheme-colors))


;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                  ;;;                                 ;;;                                        
;                  ;;;                                 ;;;                                        
;    ;;;     ;;;   ;;;   ;;;   ;;; ;;    ;;;;    ;;;   ;;; ;;    ;;;;  ;;; ;; ;;;    ;;;;   ;;;;  
;   ;;;;;   ;;;;;  ;;;  ;;;;;  ;;;;;    ;;; ;;  ;;;;;  ;;;;;;;  ;; ;;; ;;;;;;;;;;;  ;; ;;; ;;; ;; 
;  ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;;      ;;;    ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;    
;  ;;;     ;;; ;;; ;;; ;;; ;;; ;;;       ;;;;  ;;;     ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;;  ;;;;  
;  ;;;  ;; ;;; ;;; ;;; ;;; ;;; ;;;         ;;; ;;;  ;; ;;; ;;; ;;;     ;;; ;;; ;;; ;;;        ;;; 
;   ;;;;;   ;;;;;  ;;;  ;;;;;  ;;;      ;; ;;;  ;;;;;  ;;; ;;;  ;;;;;; ;;; ;;; ;;;  ;;;;;; ;; ;;; 
;    ;;;     ;;;   ;;;   ;;;   ;;;       ;;;;    ;;;   ;;; ;;;   ;;;;  ;;; ;;; ;;;   ;;;;   ;;;;  
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 

(define default-example
  (string-append
   "#lang racket   ; draw a graph of\n"
   "(require plot) ; cos and log\n"
   "(plot #:title \"y = cos(x) & y = log(x)\"\n"
   "      (list (function cos -5 5) (function log -5 5)))\n"
   "\"an unclosed string is an error"))

(struct color-scheme (name button-label white-on-black-base? mapping example inverted-base-name) #:transparent)
(define black-on-white-color-scheme-name 'classic)
(define white-on-black-color-scheme-name 'white-on-black)
(define known-color-schemes
  ;; note: first item in this list must be the default black-on-white color scheme
  ;; and the second must the default white-on-black color scheme
  (list (color-scheme black-on-white-color-scheme-name
                      (string-constant classic-color-scheme)
                      #f (make-hash) default-example
                      white-on-black-color-scheme-name)
        (color-scheme white-on-black-color-scheme-name
                      (string-constant white-on-black-color-scheme)
                      #t (make-hash) default-example
                      black-on-white-color-scheme-name)))

(define color-change-callbacks (make-hash))

(define known-color-names (set))
(define known-style-names (set))

(define (get-color-scheme-names) (values known-color-names known-style-names))

(define-logger color-scheme)

(define white-on-black-color-scheme? wob-cs:white-on-black-color-scheme?)

(define (register-info-based-color-schemes)
  (log-color-scheme-info
   "color-names: ~a\nstyle-names:\n~a\n" 
   (sort (set->list known-color-names) symbol<?)
   (sort (set->list known-style-names) symbol<?))
  (define preferred-color-scheme (if (white-on-black-color-scheme?)
                                     (preferences:get 'framework:color-scheme-dark)
                                     (preferences:get 'framework:color-scheme-light)))
  (for ([dir (in-list (find-relevant-directories '(framework:color-schemes)))])
    (define info (with-handlers ([exn:fail?
                                  (λ (x)
                                    (define sp (open-output-string))
                                    (parameterize ([current-error-port sp])
                                      ((error-display-handler)
                                       (if (exn? x) (exn-message x) (format "uncaught exn: ~s" x))
                                       x))
                                    (log-color-scheme-warning
                                     "info file in ~a failed to load:\n~a"
                                     dir
                                     (get-output-string sp))
                                    #f)])
                   (get-info/full dir)))
    (when info
      (define cs-info (info 'framework:color-schemes (lambda () "wrong answer")))
      (cond
        [(info-file-result-check? cs-info)
         (for ([one-scheme (in-list cs-info)])
           (define name (hash-ref one-scheme 'name 
                                  (λ ()
                                    (define d (path->module-path dir))
                                    (if (path-string? d)
                                        (format "~a" d)
                                        (format "~s" d)))))
           (define white-on-black-base? (hash-ref one-scheme 'white-on-black-base? #f))
           (define inverted-base-name (hash-ref one-scheme 'inverted-base-name #f))
           (define mapping (hash-ref one-scheme 'colors '()))
           (define example (hash-ref one-scheme 'example default-example))
           (define (tidy-name name)
             (if (symbol? name)
                 (if (string-constant? name)
                     (dynamic-string-constant name)
                     (symbol->string name))
                 name))
           (register-color-scheme (tidy-name name)
                                  white-on-black-base?
                                  mapping
                                  example
                                  #:inverted-base-name
                                  (and inverted-base-name
                                       (tidy-name inverted-base-name))))]
        [else
         (when cs-info
           (log-color-scheme-warning
            "expected something matching:\n~a\nfor framework:color-schemes in ~a, got\n~a"
            (pretty-format (contract-name info-file-result-check?))
            dir
            (pretty-format cs-info)))])))
  (check/fix-inverted-base-names)
  ;; the color-scheme saved in the user's preferences may not be known
  ;; until after the code above executes, which would mean that the 
  ;; color scheme in effect up to that point may be wrong. So fix that here:
  (set-current-color-scheme preferred-color-scheme))


;; register-color-scheme : string boolean? (listof (cons/c symbol? (listof props)) -> void
;; props = (or/c 'bold 'italic 'underline 
;;              
;; called based on the contents of info.rkt files
(define (register-color-scheme scheme-name white-on-black-base? mapping example
                               #:inverted-base-name [inverted-base-name #f])
  (define (good-line? line)
    (or (set-member? known-color-names (car line))
        (set-member? known-style-names (car line))))
  (for ([x (in-list mapping)])
    (unless (good-line? x)
      (log-color-scheme-warning "unknown style/color name: ~s" x)))
  (set! known-color-schemes
        (append known-color-schemes
                (list
                 (color-scheme
                  (if (symbol? scheme-name)
                      scheme-name
                      (string->symbol scheme-name))
                  (if (symbol? scheme-name)
                      (dynamic-string-constant scheme-name)
                      scheme-name)
                  white-on-black-base?
                  (make-hash
                   (for/list ([line (in-list mapping)]
                              #:when (good-line? line))
                     (define name (car line))
                     (cons name
                           (cond
                             [(set-member? known-color-names name)
                              (props->color (cdr line))]
                             [(set-member? known-style-names name)
                              (props->style-delta (cdr line))]))))
                  example
                  (cond
                    [(symbol? inverted-base-name)
                     inverted-base-name]
                    [(not inverted-base-name) #f]
                    [else
                     (string->symbol inverted-base-name)]))))))

(define (check/fix-inverted-base-names)
  (define name->scheme
    (for/hash ([a-color-scheme (in-list known-color-schemes)])
      (values (color-scheme-name a-color-scheme)
              a-color-scheme)))
  (set! known-color-schemes
        (for/list ([a-color-scheme (in-list known-color-schemes)])
          (match-define (color-scheme name button-label white-on-black-base?
                                      mapping example inverted-base-name)
            a-color-scheme)
          (let/ec escape
            (define (fail why-fmt . args)
              (log-error (apply format why-fmt args))
              (escape (color-scheme name button-label white-on-black-base?
                                    mapping example #f)))
            (when inverted-base-name
              (define inverted (hash-ref name->scheme inverted-base-name #f))
              (unless inverted (fail "color scheme named ~s has an inverted-base-name ~s but that color scheme does not exist"
                                     name inverted-base-name))
              (unless (equal? (not (color-scheme-white-on-black-base? inverted))
                              white-on-black-base?)
                (fail "color scheme named ~s has ~s and so does its inverted-base-name color scheme, ~s"
                      name
                      (if white-on-black-base?
                          "a white on black base"
                          "a black on white base")
                      inverted-base-name)))
            a-color-scheme))))

(define (get-inverted-base-color-scheme cs-name)
  (define cs (lookup-color-scheme cs-name))
  (cond
    [cs
     (define inverted-base-name (color-scheme-inverted-base-name cs))
     (cond
       [inverted-base-name
        (define inverted-base (lookup-color-scheme inverted-base-name))
        (cond
          [(equal? (white-on-black-color-scheme?)
                   (color-scheme-white-on-black-base? inverted-base))
           inverted-base-name]
          [else #f])]
       [else #f])]
    [else #f]))

(define color-vector/c
  (or/c (vector/c byte? byte? byte? #:flat? #t)
        (vector/c byte? byte? byte? (between/c 0.0 1.0) #:flat? #t)))

(struct background [color] #:prefab)

(define background-color/c
  (struct/c background color-vector/c))

(define valid-props? 
  (listof (or/c 'bold 'italic 'underline
                color-vector/c
                background-color/c)))

(define (valid-key-values? h)
  (for/and ([(k v) (in-hash h)])
    (cond
      [(equal? k 'name) (or (string? v) (symbol? v))]
      [(equal? k 'white-on-black-base?) (boolean? v)]
      [(equal? k 'colors) ((listof (cons/c symbol? valid-props?)) v)]
      [(equal? k 'example) (string? v)]
      [else 
       ;; don't care about other keys, as they'll be ignored
       #t])))

(define info-file-result-check?
  (listof (and/c hash?
                 immutable?
                 valid-key-values?)))

(define (props->color line)
  (or (for/or ([v (in-list line)])
        (and (vector? v)
             (vec->color v)))
      (vec->color #(0 0 0))))

(define (props->style-delta line)
  (define sd (new style-delta%))
  (for ([prop (in-list line)])
    (match prop
      [`bold (send sd set-delta 'change-bold)]
      [`italic (send sd set-delta 'change-italic)]
      [`underline (send sd set-delta 'change-underline #t)]
      [(? background-color/c)
       (send sd set-delta-background (vec->color (background-color prop)))]
      [else (send sd set-delta-foreground (vec->color prop))]))
  sd)

(define (vec->color v)
  (make-object color% 
    (vector-ref v 0)
    (vector-ref v 1)
    (vector-ref v 2)
    (if (= (vector-length v) 4)
        (vector-ref v 3)
        1.0)))

;; returns the user's preferred color, wrt to the current color scheme
(define (lookup-in-color-scheme color-name #:wob? [wob? (white-on-black-color-scheme?)])
  (lookup-in-color-scheme/given-mapping 
   color-name
   (preferences:get (color-scheme-entry-name->pref-name color-name))
   (get-current-color-scheme #:wob? wob?)))

(define (lookup-in-given-color-scheme color-name color-scheme)
  (lookup-in-color-scheme/given-mapping 
   color-name
   (preferences:get (color-scheme-entry-name->pref-name color-name))
   color-scheme))

(define (lookup-in-color-scheme/given-mapping color-name table a-color-scheme)
  (cond
    ;; check if the user adjusted the color
    [(hash-ref table (color-scheme-name a-color-scheme) #f)
     =>
     values]
    ;; check if the color scheme has that mapping
    [(hash-ref (color-scheme-mapping a-color-scheme)
               color-name
               #f)
     => values]
    [else
     ;; fall back to either the white-on-black or the black-on-white color scheme
     (define fallback-color-scheme
       (lookup-color-scheme
        (if (color-scheme-white-on-black-base? a-color-scheme)
            white-on-black-color-scheme-name
            black-on-white-color-scheme-name)))
     (hash-ref (color-scheme-mapping fallback-color-scheme)
               color-name)]))

;; set-color : symbol (or/c string? (is-a?/c color%) (is-a?/c style-delta%)) -> void
(define (set-in-color-scheme color-name clr/sd)
  (define table (preferences:get (color-scheme-entry-name->pref-name color-name)))
  (define current-color-scheme (get-current-color-scheme #:wob? (white-on-black-color-scheme?)))
  (define scheme-name (color-scheme-name current-color-scheme))
  (define new-table
    (cond
      [(set-member? known-style-names color-name)
       ;; it would be good to be able to use hash-remove here when 
       (hash-set table scheme-name clr/sd)]
      [else
       (define color (->color-object clr/sd))
       (define default 
         (hash-ref (color-scheme-mapping current-color-scheme)
                   color-name
                   #f))
       (cond
         [(and default (same-color? color default))
          (hash-remove table scheme-name)]
         [else
          (hash-set table scheme-name color)])]))
  (preferences:set (color-scheme-entry-name->pref-name color-name) new-table))

(define (->color-object clr)
  (if (string? clr)
      (send the-color-database find-color clr)
      clr))

(define (same-color? c1 c2)
  (and (= (send c1 red) (send c2 red))
       (= (send c1 green) (send c2 green))
       (= (send c1 blue) (send c2 blue))
       (= (send c1 alpha) (send c2 alpha))))

(define (get-current-color-scheme #:wob? wob?)
  ;; if pref is not recognized as an existing color scheme name,
  ;; return one of the two original color schemes so that
  ;; if some color scheme goes away, we have some
  ;; reasonable backup plan (and, if it comes back
  ;; we don't lose the prefs)
  (define pref-name (if wob? 'framework:color-scheme-dark 'framework:color-scheme-light))
  (define pref-val (preferences:get pref-name))
  (define found-color-scheme (lookup-color-scheme pref-val))
  (cond
    [found-color-scheme found-color-scheme]
    [wob? (built-in-wob-color-scheme)]
    [else (built-in-color-scheme)]))

(define (get-current-color-scheme-name #:wob? [wob? (white-on-black-color-scheme?)])
  (color-scheme-name (get-current-color-scheme #:wob? wob?)))

;; string -> (or/c #f color-scheme?)
(define (lookup-color-scheme name)
  (for/or ([known-color-scheme (in-list known-color-schemes)])
    (and (equal? name (color-scheme-name known-color-scheme))
         known-color-scheme)))

(define (built-in-wob-color-scheme) (list-ref known-color-schemes 1))
(define (built-in-color-scheme) (list-ref known-color-schemes 0))

(define (set-current-color-scheme name)
  (define color-scheme
    (or (for/or ([known-color-scheme (in-list known-color-schemes)])
          (and (equal? name (color-scheme-name known-color-scheme))
               known-color-scheme))
        (car known-color-schemes)))
  (preferences:set (if (color-scheme-white-on-black-base? color-scheme)
                       'framework:color-scheme-dark
                       'framework:color-scheme-light)
                   (color-scheme-name color-scheme))
  (when (equal? (color-scheme-white-on-black-base? color-scheme)
                (white-on-black-color-scheme?))
    (change-colors-to-match-color-scheme color-scheme)))

(define (change-colors-to-match-color-scheme color-scheme)
  (if (color-scheme-white-on-black-base? color-scheme)
      (white-on-black)
      (black-on-white))
  (define style-lists-begun '())
  (dynamic-wind
   (λ ()
     (set! style-lists-begun
           (for*/list ([(color-name fns+sls) (in-hash color-change-callbacks)]
                       [fn+sl (in-list fns+sls)])
             (define sl/b (cdr fn+sl))
             (define sl (if (weak-box? sl/b)
                            (weak-box-value sl/b)
                            sl/b))
             (and sl (send sl begin-style-change-sequence) sl))))
   (λ ()
     (for ([(color-name fns+sls) (in-hash color-change-callbacks)])
       (for ([fn/b (in-list (map car fns+sls))])
         (define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b))
         (when fn
           (fn (lookup-in-given-color-scheme color-name color-scheme))))))
   (λ ()
     (for ([style-list (in-list style-lists-begun)])
       (when style-list
         (send style-list end-style-change-sequence))))))

(define (get-available-color-schemes) 
  (for/list ([(name a-color-scheme) (in-hash known-color-schemes)])
    name))

(define (register-color-scheme-entry-change-callback color fn [weak? #f]
                                                     #:style-list [style-list #f])
  (define wb/f (if weak?
                   (cons (make-weak-box fn) (make-weak-box style-list))
                   (cons fn style-list)))
  ;; so we know which callbacks to call when a color scheme change happens
  (hash-set! color-change-callbacks 
             color
             (cons wb/f
                   (remove-gones (hash-ref color-change-callbacks color '()))))
  ;; so that individual color changes in a given scheme get callbacks
  (define remover
    (preferences:add-callback
     (color-scheme-entry-name->pref-name color)
     (λ (pref ht)
       (define fn
         (cond
           [(weak-box? (car wb/f))
            (define fn (weak-box-value (car wb/f)))
            (unless fn (remover))
            fn]
           [else (car wb/f)]))
       (when fn
         (fn (lookup-in-color-scheme/given-mapping
              color
              ht
              (get-current-color-scheme
               #:wob? (white-on-black-color-scheme?))))))))
  (void))

;; we remove elements of the list when the function isn't reachable anymore
;; if the style-list isn't reachable we'll keep the function in there.
(define (remove-gones lst)
  (for/list ([fn+sl (in-list lst)]
             #:when (or (not (weak-box? (car fn+sl)))
                        (weak-box-value (car fn+sl))))
    fn+sl))

(define (known-color-scheme-name? n) 
  (or (set-member? known-color-names n) 
      (set-member? known-style-names n)))

(define (color-scheme-style-name? n)
  (set-member? known-style-names n))

(define (color-scheme-color-name? n)
  (set-member? known-color-names n))

(define (color-scheme-entry-name->pref-name sym)
  (string->symbol (format "color-scheme-entry:~a" sym)))

(define name->style-name (make-hash))

(define (add-color-scheme-entry name _b-o-w-color _w-o-b-color 
                                #:style [style-name #f]
                                #:bold? [bold 'base]
                                #:underline? [underline? #f]
                                #:italic? [italic? #f]
                                #:background [background #f])
  (define b-o-w-color (->color-object _b-o-w-color))
  (define w-o-b-color (->color-object _w-o-b-color))
  (cond
    [style-name
     (set! known-style-names (set-add known-style-names name))
     (hash-set! name->style-name name style-name)]
    [else
     (set! known-color-names (set-add known-color-names name))])
  (define (update-color scheme-name color)
    (hash-set! (color-scheme-mapping (lookup-color-scheme scheme-name))
               name
               (if style-name
                   (make-style-delta color bold underline? italic? #:background background)
                   color)))
  (update-color white-on-black-color-scheme-name w-o-b-color)
  (update-color black-on-white-color-scheme-name b-o-w-color)
  (preferences:set-default (color-scheme-entry-name->pref-name name)
                           (hash)
                           (hash/c symbol?
                                   (if style-name 
                                       (is-a?/c style-delta%)
                                       (is-a?/c color%))
                                   #:immutable #t))
  (preferences:set-un/marshall 
   (color-scheme-entry-name->pref-name name)
   (λ (h)
     (for/hash ([(k v) (in-hash h)])
       (values k
               (if style-name
                   (marshall-style-delta v)
                   (vector (send v red) (send v green) (send v blue) (send v alpha))))))
   (λ (val)
     (cond
       [(and (list? val) (= (length val) (length style-delta-get/set)))
        ;; old style prefs; check to see if this user
        ;; was using the white on black or black on white and 
        ;; build the corresponding new pref
        (hash (if (preferences:get 'framework:white-on-black?)
                  white-on-black-color-scheme-name
                  black-on-white-color-scheme-name)
              (if background
                  (unmarshall-style-delta-with-background val)
                  (unmarshall-style-delta val)))]
       [(unmarshall-color val)
        => 
        (λ (clr)
          ;; old color prefs; as above
          (hash (if (preferences:get 'framework:white-on-black?)
                    white-on-black-color-scheme-name
                    black-on-white-color-scheme-name)
                clr))]
       [(hash? val)
        ;; this may return a bogus hash, but the preferences system will check
        ;; and revert this to the default pref in that case
        (for/hash ([(k v) (in-hash val)])
          (values 
           k 
           (if style-name
               (if background
                   (unmarshall-style-delta-with-background v)
                   (unmarshall-style-delta v))
               (and (vector? v)
                    (= (vector-length v) 4)
                    (make-object color% 
                      (vector-ref v 0) (vector-ref v 1) 
                      (vector-ref v 2) (vector-ref v 3))))))]
       [else #f])))
  
  (when style-name
    (register-color-scheme-entry-change-callback
     name
     (λ (sd)
       (editor:set-standard-style-list-delta style-name sd))
     #:style-list (editor:get-standard-style-list))
    (define init-value (lookup-in-color-scheme name))
    (editor:set-standard-style-list-delta style-name init-value)))

(define color-scheme-examples-parents '())
(define (update-dark-light-preferences-panel-ordering dark-should-be-first?)
  (for ([color-scheme-examples-parent (in-list color-scheme-examples-parents)])
    (define dark-is-first?
      (let loop ([area (car (send color-scheme-examples-parent get-children))])
        (cond
          [(is-a? area message%)
           (equal? (send area get-label) (string-constant dark-color-scheme))]
          [(is-a? area area-container<%>)
           (for/or ([area (in-list (send area get-children))])
             (loop area))]
          [else #f])))
    (unless (equal? dark-should-be-first? dark-is-first?)
      (send color-scheme-examples-parent
            change-children
            reverse))))

(preferences:add-callback
 'framework:white-on-black-mode?
 (λ (p v)
   (update-dark-light-preferences-panel-ordering
    (match v
      ['platform (white-on-black-panel-scheme?)]
      [#t #t]
      [#f #f]))))

(define (add-color-scheme-preferences-panel #:extras [extras void])
  (preferences:add-panel
   (list (string-constant preferences-colors)
         (string-constant color-schemes))
   (λ (parent)
     (define vp 
       (new-vertical-panel% 
            [parent parent]
            [style '(auto-vscroll)]))
     (define top-hp (new-horizontal-panel%
                     [parent vp]
                     [stretchable-height #f]
                     [alignment '(center center)]))
     (define top-hp2 (new-horizontal-panel%
                      [parent vp]
                      [stretchable-height #f]
                      [alignment '(center center)]))
     (define white-on-black-mode-choice
       (case (system-type)
         [(windows)
          (new choice%
               [parent top-hp]
               [label (string-constant color-mode)]
               [choices (list (string-constant light-mode)
                              (string-constant dark-mode))]
               [selection (if (preferences:get 'framework:white-on-black-mode?) 1 0)]
               [callback
                (λ (_1 _2)
                  (preferences:set 'framework:white-on-black-mode?
                                   (match (send white-on-black-mode-choice get-selection)
                                     [0 #f]
                                     [1 #t])))])]
         [else
          (new choice%
               [parent top-hp]
               [label (string-constant color-mode)]
               [choices (list (string-constant use-os-dark-mode-selection)
                              (string-constant always-light-mode)
                              (string-constant always-dark-mode))]
               [callback
                (λ (_1 _2)
                  (preferences:set 'framework:white-on-black-mode?
                                   (match (send white-on-black-mode-choice get-selection)
                                     [0 'platform]
                                     [1 #f]
                                     [2 #t])))])]))
     (case (system-type)
       [(windows)
        (preferences:add-callback
         'framework:white-on-black-mode?
         (λ (_1 val)
           (send white-on-black-mode-choice
                 set-selection
                 (if val 1 0))))]
       [else
        (preferences:add-callback
         'framework:white-on-black-mode?
         (λ (_1 val)
           (send white-on-black-mode-choice
                 set-selection
                 (match val
                   ['platform 0]
                   [#t 2]
                   [#f 1]))))])

     (define color-scheme-examples-vp
       (new-vertical-panel%
        [spacing 10]
        [border 10]
        [parent vp]))
     (set! color-scheme-examples-parents
           (cons
            color-scheme-examples-vp
            color-scheme-examples-parents))
     (define (mk-color-scheme-radio-buttons white-on-black? radio-panel pref-sym)
       (for ([color-scheme (in-list known-color-schemes)]
             #:when (equal? white-on-black? (color-scheme-white-on-black-base? color-scheme)))
         (define vp (new-vertical-panel%
                     [parent radio-panel]
                     [alignment '(left top)]
                     [stretchable-height #f]))
         (define label (new radio-box%
                            [parent vp]
                            [label #f]
                            [selection
                             (if (equal? (preferences:get pref-sym)
                                         (color-scheme-name color-scheme))
                                 0
                                 #f)]
                            [callback
                             (λ (_1 _2)
                               (preferences:set
                                pref-sym
                                (color-scheme-name color-scheme)))]
                            [choices (list (color-scheme-button-label color-scheme))]))
         (preferences:add-callback
          pref-sym
          (λ (p v)
            (send label set-selection
                  (if (equal? v (color-scheme-name color-scheme))
                      0
                      #f))))
         (define t (new racket:text%))
         (define str (color-scheme-example color-scheme))
         (send t insert str)
         (define inner-hp (new-horizontal-panel%
                           [parent vp]
                           [stretchable-height #f]))
         (define spacer (new panel%
                             [parent inner-hp]
                             [stretchable-width #f]))
         (send spacer min-width 40)
         (define ec (new editor-canvas%
                         [parent inner-hp]
                         [style '(no-border auto-hscroll no-vscroll)]
                         [editor t]))
         (send ec set-line-count (+ 1 (for/sum ([c (in-string str)])
                                        (if (equal? c #\newline)
                                            1
                                            0))))
         (define bkg-name 'framework:basic-canvas-background)
         (send ec set-canvas-background
               (lookup-in-color-scheme/given-mapping
                bkg-name
                (preferences:get (color-scheme-entry-name->pref-name bkg-name))
                color-scheme))
         (send t set-style-list (color-scheme->style-list color-scheme #f))))

     (define dark-panel (new vertical-panel%
                             [parent color-scheme-examples-vp]
                             [stretchable-height #f]
                             [style '(border)]))
     (define light-panel (new vertical-panel%
                              [parent color-scheme-examples-vp]
                              [stretchable-height #f]
                              [style '(border)]))
     (new message%
          [parent dark-panel]
          [label (string-constant dark-color-scheme)])
     (new message%
          [parent light-panel]
          [label (string-constant light-color-scheme)])
     (mk-color-scheme-radio-buttons #t dark-panel 'framework:color-scheme-dark)
     (mk-color-scheme-radio-buttons #f light-panel 'framework:color-scheme-light)

     (update-dark-light-preferences-panel-ordering
      (white-on-black-color-scheme?))

     (define revert-button%
       (new button%
            [label (string-constant revert-colors-to-color-scheme-defaults)]
            [parent vp]
            [callback
             (λ (x y)
               (revert-to-color-scheme-defaults
                (get-current-color-scheme
                 #:wob?
                 (white-on-black-color-scheme?))))]))
     (extras vp)
     (void))))

(define (revert-to-color-scheme-defaults color-scheme)
  (define cs-name (color-scheme-name color-scheme))
  (for ([name (in-set (set-union known-style-names known-color-names))])
    (define pref-sym (color-scheme-entry-name->pref-name name))
    (define pref-hash (preferences:get pref-sym))
    (when (hash-ref pref-hash cs-name #f)
      (preferences:set pref-sym (hash-remove pref-hash cs-name)))))

(define (color-scheme->style-list color-scheme defaults?)
  (define style-list (new style-list%))
  
  (define standard-delta (make-object style-delta% 'change-normal))
  (send standard-delta set-delta 'change-family 'modern)
  (send standard-delta set-size-mult 0)
  (send standard-delta set-size-add (editor:get-current-preferred-font-size))
  (send standard-delta set-delta-face (preferences:get 'framework:standard-style-list:font-name))
  (send standard-delta set-weight-on (preferences:get 'framework:standard-style-list:weight))
  (send standard-delta set-smoothing-on (preferences:get 'framework:standard-style-list:smoothing))
  (send style-list new-named-style "Standard"
        (send style-list find-or-create-style
              (send style-list basic-style)
              standard-delta))
  (define (update-standard-delta f)
    (define delta (make-object style-delta%))
    (define std (send style-list find-named-style "Standard"))
    (send std get-delta delta)
    (f delta)
    (send std set-delta delta))
  (preferences:add-callback
   'framework:standard-style-list:weight
   (λ (p v) (update-standard-delta (lambda (delta) (send delta set-weight-on v)))))
  (preferences:add-callback
   'framework:standard-style-list:smoothing
   (λ (p v) (update-standard-delta (lambda (delta) (send delta set-smoothing-on v)))))
  (for ([name (in-set known-style-names)])
    (define pref-hash (preferences:get (color-scheme-entry-name->pref-name name)))
    (define delta
      (lookup-in-color-scheme/given-mapping
       name 
       (if defaults? (hash) pref-hash)
       color-scheme))
    (send style-list new-named-style
          (hash-ref name->style-name name)
          (send style-list find-or-create-style
                (send style-list find-named-style "Standard")
                delta)))
  style-list)
