Last icon rewrite!

This removes all the SVG sources, parsing, and marked-layer colorizing, the PNG binaries in the distribution, and the dependence of DrRacket on `slideshow/pict'.

Icons are now produced by drawing on a bitmap-dc%, inferring or building a z map, choosing a material, and sending these to a two-pass ray tracer. This is for the most part hidden behind an API consisting of functions from colors and optional sizes and materials to `bitmap%'s.

Contracts and documentation forthcoming.

collects/drracket/private/debug.rkt

@@ -26,7 +26,7 @@ profile todo:
          net/url
          racket/match
          mrlib/include-bitmap
-         icons
+         images/icons/misc images/icons/style images/icons/control
          (for-syntax racket/base))
 
 (define orig (current-output-port))
@@ -187,10 +187,11 @@ profile todo:
                      (super-make-object bitmap))])
            note%)))
   
-  (define bug-note% (make-note% "stop-multi.png" (stop-signs-icon)))
+  (define file-note% (make-note% "stop-22x22.png" (stop-sign-icon halt-icon-color)))
+  (define bug-note% (make-note% "stop-multi.png" (stop-signs-icon halt-icon-color)))
+  
   (define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif)))
-  (define file-note% (make-note% "stop-22x22.png" (stop-sign-icon)))
-  (define small-planet-bitmap (earth-icon))
+  (define small-planet-bitmap (record-icon "blue"))
   (define planet-note% (make-note% "small-planet.png" small-planet-bitmap))
   
   ;; display-stats : (syntax -> syntax)

collects/drracket/private/unit.rkt

@@ -38,7 +38,7 @@ module browser threading seems wrong.
          "local-member-names.rkt"
          "eval-helpers.rkt"
          (prefix-in drracket:arrow: "../arrow.rkt")
-         (prefix-in icons: icons) (prefix-in pict: slideshow/pict)
+         (prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style))
          
          mred
          (prefix-in mred: mred)
@@ -385,18 +385,12 @@ module browser threading seems wrong.
                    frame
                    program-filename)))])))
   
-  (define execute-bitmap (icons:go-icon 'green (icons:toolbar-icon-height)))
-  (define break-bitmap (icons:stop-icon 'red (icons:toolbar-icon-height)))
-  
-  (define blue-arrow-pict (icons:right-arrow-icon-pict 'blue (* 3/4 (icons:toolbar-icon-height))))
-  (define disk-pict (icons:disk-icon-pict 'orange (icons:toolbar-icon-height)))
-  
-  (define small-save-bitmap
-    (pict:pict->bitmap
-     (pict:rc-superimpose
-      disk-pict (pict:inset blue-arrow-pict 0 0 (* 1/2 (icons:toolbar-icon-height)) 0))))
-  
-  (define save-bitmap (pict:pict->bitmap (pict:hc-append blue-arrow-pict disk-pict)))
+  (define execute-bitmap (icons:play-icon icons:run-icon-color (icons:toolbar-icon-height)))
+  (define break-bitmap (icons:stop-icon icons:halt-icon-color (icons:toolbar-icon-height)))
+  (define small-save-bitmap (icons:small-save-icon icons:syntax-icon-color icons:metal-icon-color
+                                                   (icons:toolbar-icon-height)))
+  (define save-bitmap (icons:save-icon icons:syntax-icon-color icons:metal-icon-color
+                                       (icons:toolbar-icon-height)))
   
   (define-values (get-program-editor-mixin add-to-program-editor-mixin)
     (let* ([program-editor-mixin
@@ -4702,7 +4696,7 @@ module browser threading seems wrong.
         [(null? l) '()]
         [else (cons (car l) (loop (cdr l) (- n 1)))])))
   
-  (define very-small-planet-bitmap (icons:earth-icon (icons:toolbar-icon-height)))
+  (define very-small-planet-bitmap (icons:record-icon "blue" (icons:toolbar-icon-height)))
   
   (define saved-bug-reports-window #f)
   (define saved-bug-reports-panel #f)

collects/drracket/syncheck-drracket-button.rkt

@@ -2,7 +2,7 @@
 (require racket/class 
          racket/gui/base
          string-constants/string-constant
-         icons slideshow/pict)
+         images/icons/tool images/icons/style)
 (provide syncheck-drracket-button
          syncheck-bitmap
          syncheck-small-bitmap
@@ -10,14 +10,8 @@
 
 (define-local-member-name syncheck:button-callback)
 
-(define syncheck-bitmap
-  (pict->bitmap (hb-append (magnifying-glass-left-icon-pict (* 7/8 (toolbar-icon-height)))
-                           (check-icon-pict 'green (toolbar-icon-height)))))
-
-(define syncheck-small-bitmap
-  (pict->bitmap (rb-superimpose (hc-append (check-icon-pict 'green (toolbar-icon-height))
-                                           (blank (* 1/4 (toolbar-icon-height))))
-                                (magnifying-glass-icon-pict (* 3/4 (toolbar-icon-height))))))
+(define syncheck-bitmap (check-syntax-icon (toolbar-icon-height)))
+(define syncheck-small-bitmap (small-check-syntax-icon (toolbar-icon-height)))
 
 (define syncheck-drracket-button
   (list 

collects/gui-debugger/debug-tool.rkt

@@ -15,7 +15,7 @@
            framework
            string-constants
            lang/debugger-language-interface
-           icons)
+           images/icons/tool)
   
   (provide tool@)
   
@@ -40,6 +40,7 @@
            (new switchable-button%
                 (label (string-constant debug-tool-button-name))
                 (bitmap debug-bitmap)
+                (alternate-bitmap small-debug-bitmap)
                 (parent parent)
                 (callback (λ (button) (send frame debug-callback)))))
          'macro-stepper)
@@ -1081,7 +1082,8 @@
           
           (super-new)))
       
-      (define debug-bitmap (step-icon 'green (toolbar-icon-height)))
+      (define debug-bitmap (debugger-icon))
+      (define small-debug-bitmap (small-debugger-icon))
       
       (define make-pause-label
         (bitmap-label-maker
@@ -1353,6 +1355,7 @@
             (new switchable-button%
                  (label (string-constant debug-tool-button-name))
                  (bitmap debug-bitmap)
+                 (alternate-bitmap small-debug-bitmap)
                  (parent (new vertical-pane%
 			      [parent (get-button-panel)]
 			      [alignment '(center center)]))

collects/gui-debugger/info.rkt

@@ -2,4 +2,4 @@
 
 (define tools '(("debug-tool.rkt")))
 (define tool-names '("Graphical Debugger"))
-(define tool-icons '(("clanbomber-32x32.png" "gui-debugger" "icons")))
+(define tool-icons '(("bomb-32x32.png" "icons")))

collects/icons/info.rkt

@@ -1,5 +0,0 @@
-#lang setup/infotab
-
-(define scribblings '(["scribblings/icons.scrbl" () (gui-library)]))
-
-(define compile-omit-paths '("tests" "private/svg"))

collects/icons/main.rkt

@@ -1,51 +0,0 @@
-#lang racket/base
-
-(require unstable/latent-contract
-         "private/svg.rkt"
-         "private/utils.rkt")
-
-(provide (activate-contract-out
-          icon-colors
-          icon-color/c
-          icon-styles
-          icon-style/c
-          toolbar-icon-height
-          default-icon-height
-          default-icon-style
-          load-icon-pict
-          load-icon
-          icon-categories
-          icon-names
-          
-          go-icon go-icon-pict
-          bar-icon bar-icon-pict
-          back-icon back-icon-pict
-          stop-icon stop-icon-pict
-          record-icon record-icon-pict
-          step-icon step-icon-pict
-          step-back-icon step-back-icon-pict
-          continue-icon continue-icon-pict
-          continue-back-icon continue-back-icon-pict
-          fast-forward-icon fast-forward-icon-pict
-          rewind-icon rewind-icon-pict
-          pause-icon pause-icon-pict
-          stop-sign-icon stop-sign-icon-pict
-          check-icon check-icon-pict
-          x-icon x-icon-pict
-          magnifying-glass-icon magnifying-glass-icon-pict
-          magnifying-glass-left-icon magnifying-glass-left-icon-pict
-          disk-icon disk-icon-pict
-          standing-icon standing-icon-pict
-          running-icon running-icon-pict
-          up-arrow-icon up-arrow-icon-pict
-          down-arrow-icon down-arrow-icon-pict
-          left-arrow-icon left-arrow-icon-pict
-          right-arrow-icon right-arrow-icon-pict
-          stop-signs-icon stop-signs-icon-pict
-          earth-icon earth-icon-pict
-          moon-icon moon-icon-pict
-          hash-quote-icon hash-quote-icon-pict
-          plus-icon plus-icon-pict
-          times-icon times-icon-pict
-          plt-logo plt-logo-pict
-          planet-logo planet-logo-pict))

collects/icons/private/doc.rkt

@@ -1,9 +0,0 @@
-#lang racket/base
-
-(require unstable/latent-contract/defthing
-         "svg.rkt"
-         "utils.rkt")
-
-(provide (only-doc-out
-          (combine-out (all-from-out "svg.rkt")
-                       (all-from-out "utils.rkt"))))

collects/icons/private/svg.rkt

@@ -1,238 +0,0 @@
-#lang racket/base
-
-(require racket/class racket/draw racket/list
-         racket/contract
-         unstable/latent-contract/defthing
-         (for-syntax racket/base
-                     racket/syntax)
-         "utils.rkt"
-         slideshow/pict)
-
-(provide (all-defined-out))
-
-(defthing icon-styles (listof symbol?) #:document-value '(diffuse shiny))
-(defcontract icon-style/c (or/c #f 'diffuse 'shiny))
-
-(defparam toolbar-icon-height (>/c 1) 16)
-(defparam default-icon-height (>/c 1) 24)
-(defparam default-icon-style (or/c 'diffuse 'shiny) 'diffuse)
-
-(define (icon-file-name category name color height style) string?
-  (define cs-name (cond [(and color style)  (format "~a/~a-~a" color name style)]
-                        [color  (format "~a/~a" color name)]
-                        [style  (format "~a-~a" name style)]
-                        [else   (format "~a" name)]))
-  (format "~a/~a/~a.png" category height cs-name))
-
-(defproc (load-icon-pict [category string?]
-                         [name string?]
-                         [color icon-color/c]
-                         [height (>=/c 0) (default-icon-height)]
-                         [style icon-style/c (default-icon-style)]) pict?
-  (define hs (icon-category-heights category))
-  (define icon-height
-    (let ([h  (for/first ([h  (in-list hs)] #:when (height . <= . h)) h)])
-      (if h h (last hs))))
-  (define icon-path
-    (build-path svg-icons-base-path (icon-file-name category name color icon-height style)))
-  (scale (bitmap icon-path) (/ height icon-height)))
-
-(defproc (load-icon [category string?]
-                    [name string?]
-                    [color icon-color/c]
-                    [height (>=/c 0) (default-icon-height)]
-                    [style icon-style/c (default-icon-style)]) (is-a?/c bitmap%)
-  (pict->bitmap (load-icon-pict category name color height style)))
-
-(defproc (icon-categories) (listof string?)
-  (remove-duplicates
-   (let loop ([dirs empty] [res empty])
-     (define dir (apply build-path svg-icons-base-path dirs))
-     (define files (directory-list dir))
-     (append*
-      (for/list ([file  (in-list files)])
-        (define file-path (build-path dir file))
-        (cond [(exact-integer? (string->number (path->string file)))
-               res]
-              [(directory-exists? file-path)
-               (define subdirs (append dirs (list file)))
-               (loop subdirs (cons (path->string (apply build-path subdirs)) res))]
-              [else
-               empty]))))))
-
-(defproc (icon-names [category string?]) (listof string?)
-  (define files
-    (filter svg-file? (directory-list (build-path svg-icons-base-path category))))
-  (for/list ([file  (in-list files)])
-    (define-values (base-dir dir-path _) (split-path file))
-    (path->string (path-replace-suffix dir-path ""))))
-
-;; ===================================================================================================
-;; Icon pict contructors
-
-(define-syntax-rule (define-make-colorized-icon-pict [make-icon-pict category name] ...)
-  (begin
-    (defproc (make-icon-pict [color icon-color/c]
-                             [height (>=/c 0) (default-icon-height)]
-                             [style icon-style/c (default-icon-style)]) pict?
-      (load-icon-pict category name color height style))
-    ...))
-
-(define-syntax-rule (define-make-icon-pict [make-icon-pict category name] ...)
-  (begin
-    (defproc (make-icon-pict [height (>=/c 0) (default-icon-height)]
-                             [style icon-style/c (default-icon-style)]) pict?
-      (load-icon-pict category name #f height style))
-    ...))
-
-(define-make-colorized-icon-pict
-  [go-icon-pict "control" "go"]
-  [bar-icon-pict "control" "bar"]
-  [stop-icon-pict "control" "stop"]
-  [record-icon-pict "control" "record"]
-  [check-icon-pict "check" "check"]
-  [x-icon-pict "check" "x"]
-  [disk-icon-pict "misc" "disk"]
-  [standing-icon-pict "misc" "standing"]
-  [running-icon-pict "misc" "running"]
-  [plus-icon-pict "symbol" "plus"]
-  [times-icon-pict "symbol" "times"]
-  [up-arrow-icon-pict "arrow" "up"]
-  [down-arrow-icon-pict "arrow" "down"]
-  [right-arrow-icon-pict "arrow" "right"]
-  )
-
-(define-make-icon-pict
-  [stop-sign-icon-pict "sign" "stop"]
-  [magnifying-glass-icon-pict "misc" "magnifying-glass"]
-  [earth-icon-pict "misc" "earth"]
-  [moon-icon-pict "misc" "moon"]
-  [hash-quote-icon-pict "symbol" "hash-quote"]
-  [plt-logo-pict "logo" "plt"]
-  [planet-logo-pict "logo" "planet"]
-  )
-
-(defproc (back-icon-pict [color icon-color/c]
-                         [height (>=/c 0) (default-icon-height)]
-                         [style icon-style/c (default-icon-style)]) pict?
-  (pict-mirror-x (go-icon-pict color height style)))
-
-(defproc (left-arrow-icon-pict [color icon-color/c]
-                               [height (>=/c 0) (default-icon-height)]
-                               [style icon-style/c (default-icon-style)]) pict?
-  (pict-mirror-x (right-arrow-icon-pict color height style)))
-
-(defproc (magnifying-glass-left-icon-pict [height (>=/c 0) (default-icon-height)]
-                                          [style icon-style/c (default-icon-style)]) pict?
-  (pict-mirror-x (magnifying-glass-icon-pict height style)))
-
-(defproc (step-icon-pict [color icon-color/c]
-                         [height (>=/c 0) (default-icon-height)]
-                         [style icon-style/c (default-icon-style)]) pict?
-  (hc-append (go-icon-pict color height style) (bar-icon-pict color height style)))
-
-(defproc (step-back-icon-pict [color icon-color/c]
-                              [height (>=/c 0) (default-icon-height)]
-                              [style icon-style/c (default-icon-style)]) pict?
-  (hc-append (bar-icon-pict color height style) (back-icon-pict color height style)))
-
-(defproc (continue-icon-pict [color icon-color/c]
-                             [height (>=/c 0) (default-icon-height)]
-                             [style icon-style/c (default-icon-style)]) pict?
-  (hc-append (bar-icon-pict color height style) (go-icon-pict color height style)))
-
-(defproc (continue-back-icon-pict [color icon-color/c]
-                                  [height (>=/c 0) (default-icon-height)]
-                                  [style icon-style/c (default-icon-style)]) pict?
-  (hc-append (back-icon-pict color height style) (bar-icon-pict color height style)))
-
-(defproc (fast-forward-icon-pict [color icon-color/c]
-                                 [height (>=/c 0) (default-icon-height)]
-                                 [style icon-style/c (default-icon-style)]) pict?
-  (define go (go-icon-pict color height style))
-  (scale (hc-append go go) 3/4 1))
-
-(defproc (rewind-icon-pict [color icon-color/c]
-                           [height (>=/c 0) (default-icon-height)]
-                           [style icon-style/c (default-icon-style)]) pict?
-  (define back (back-icon-pict color height style))
-  (scale (hc-append back back) 3/4 1))
-
-(defproc (pause-icon-pict [color icon-color/c]
-                          [height (>=/c 0) (default-icon-height)]
-                          [style icon-style/c (default-icon-style)]) pict?
-  (define gap (blank (* 1/16 height)))
-  (define bar (bar-icon-pict color height style))
-  (hc-append gap bar gap bar gap))
-
-(defproc (stop-signs-icon-pict [height (>=/c 0) (default-icon-height)]
-                               [style icon-style/c (default-icon-style)]) pict?
-  (define h (* 2/3 height))
-  (define s1 (inset (stop-sign-icon-pict h style) (* 1/4 h) (* 1/2 h) 0 0))
-  (define s2 (inset (stop-sign-icon-pict h style) (* 1/8 h) (* 1/4 h) 0 0))
-  (define s3 (stop-sign-icon-pict h style))
-  (inset (lt-superimpose s3 s2 s1) (* 1/8 h) 0 (* 1/8 h) 0))
-
-;; ===================================================================================================
-;; Icon contructors
-
-(define-syntax (define-make-colorized-icon stx)
-  (syntax-case stx ()
-    [(_ f ...)
-     (with-syntax ([(f-pict ...)  (map (λ (f) (format-id f "~a-pict" f))
-                                       (syntax->list #'(f ...)))])
-       (syntax/loc stx
-         (begin (defproc (f [color icon-color/c]
-                            [height (>=/c 0) (default-icon-height)]
-                            [style icon-style/c (default-icon-style)]) (is-a?/c bitmap%)
-                  (pict->bitmap (f-pict color height style)))
-                ...)))]))
-
-(define-syntax (define-make-icon stx)
-  (syntax-case stx ()
-    [(_ f ...)
-     (with-syntax ([(f-pict ...)  (map (λ (f) (format-id f "~a-pict" f))
-                                       (syntax->list #'(f ...)))])
-       (syntax/loc stx
-         (begin (defproc (f [height (>=/c 0) (default-icon-height)]
-                            [style icon-style/c (default-icon-style)]) (is-a?/c bitmap%)
-                  (pict->bitmap (f-pict height style)))
-                ...)))]))
-
-(define-make-colorized-icon
-  go-icon
-  bar-icon
-  back-icon
-  stop-icon
-  record-icon
-  step-icon
-  step-back-icon
-  continue-icon
-  continue-back-icon
-  fast-forward-icon
-  rewind-icon
-  pause-icon
-  check-icon
-  x-icon
-  disk-icon
-  standing-icon
-  running-icon
-  plus-icon
-  times-icon
-  up-arrow-icon
-  down-arrow-icon
-  left-arrow-icon
-  right-arrow-icon
-  )
-
-(define-make-icon
-  stop-sign-icon
-  stop-signs-icon
-  magnifying-glass-icon
-  magnifying-glass-left-icon
-  earth-icon
-  moon-icon
-  hash-quote-icon
-  plt-logo
-  planet-logo
-  )