1 ; file: cstst.scm
  2 ; type: lepton-schematic Guile script
  3 ; copyright (c) 2021 dmn <graahnul.grom@gmail.com>
  4 ; license: GPLv2+
  5 ;
  6 ; A companion script for color scheme test schematic,
  7 ; see https://graahnul-grom.github.io/cs
  8 ;
  9 ; It provides two functions:
 10 ;
 11 ; 1) cstst-mk():
 12 ; Creates a set of boxes at the mouse pointer position
 13 ; (ensure that the mouse pointer is within the drawing area).
 14 ; The number of boxes is equal to the number of colors
 15 ; available in lepton-schematic.
 16 ; Next to each box there's a text designating the
 17 ; color number, name and hex value.
 18 ; Both the box and the text are painted using that color.
 19 ; The text is repeated using the "attribute" color.
 20 ;
 21 ; 2) cstst-up():
 22 ; If there are color boxes in current schematic (created
 23 ; with cstst-mk()), update hex color values using the color
 24 ; scheme currently loaded.
 25 ;
 26 ; Usage:
 27 ; type in the ":" prompt:
 28 ; - load this file:
 29 ;   ( primitive-load "/path/to/cstst.scm" )
 30 ; - to create color boxes, type:
 31 ;   ( cstst-mk )
 32 ; - to update color values of existing color boxes, type:
 33 ;   ( cstst-up )
 34 
 35 ( use-modules ( srfi srfi-1 ) )
 36 ( use-modules ( lepton color-map ) )
 37 ( use-modules ( lepton object ) )
 38 ( use-modules ( lepton page ) )
 39 ( use-modules ( schematic window ) )
 40 ( use-modules ( schematic undo ) )
 41 
 42 
 43 ; private:
 44 ; function: mk-color-boxes()
 45 ;
 46 ( define ( mk-color-boxes cmap pt )
 47 ( let
 48     (
 49     ( color_nam 0 )
 50     ( color_ndx 0 )
 51     ( color_hex 0 )
 52     ( x ( car pt ) )
 53     ( y ( cdr pt ) )
 54     ( box1 #f )
 55     ( box2 #f )
 56     ( txt1 #f )
 57     ( txt2 #f )
 58     ( color_ndx_attr ( color-map-name-to-index 'attribute ) )
 59     )
 60 
 61     ( for-each
 62     ( lambda( entry )
 63         ( set! color_nam ( first  entry ) )
 64         ( set! color_hex ( second entry ) ) ; NOTE: cdr() => "(#xxyyzz)"
 65         ( set! color_ndx ( color-map-name-to-index color_nam ) )
 66 
 67         ( set! box1 ( make-box (cons x y) (cons (+ x 600) (- y 500)) color_ndx ) )
 68         ( set-object-fill! box1 'solid )
 69 
 70         ( set! box2 ( make-box (cons x y) (cons (+ x 600) (- y 500)) color_ndx_attr ) )
 71 
 72         ( set! txt1
 73             ( make-text
 74                 ( cons (+ x 700) ( - y 100 ) )
 75                 'middle-left
 76                 0
 77                 ( format #f "~a=~d: ~a = ~a" color_nam color_ndx color_nam color_hex )
 78                 10
 79                 #t
 80                 'value
 81                 color_ndx_attr
 82             )
 83         )
 84 
 85         ( set! txt2
 86             ( make-text
 87                 ( cons (+ x 700) (- y 400) )
 88                 'middle-left
 89                 0
 90                 ( format #f "~a=~d: ~a = ~a" color_nam color_ndx color_nam color_hex )
 91                 10
 92                 #t
 93                 'value
 94                 color_ndx
 95             )
 96         )
 97 
 98         ( page-append! (active-page) box1 )
 99         ( page-append! (active-page) box2 )
100         ( page-append! (active-page) txt1 )
101         ( page-append! (active-page) txt2 )
102 
103         ( set! y ( - y 700 ) )
104 
105     ) ; lambda()
106 
107       cmap ; walk through [cmap] list
108 
109     ) ; for-each
110 
111 ) ; let
112 ) ; mk-color-boxes()
113 
114 
115 
116 ; public:
117 ; function: cstst-mk(): create color boxes
118 ;
119 ( define ( cstst-mk )
120     ( when ( pointer-position )
121         ( undo-save-state )
122         ( mk-color-boxes
123             ( display-color-map )
124             ( snap-point (pointer-position) )
125         )
126     )
127 )
128 
129 
130 
131 ; public:
132 ; function: cstst-up(): update color values
133 ;
134 ( define ( cstst-up )
135 ( let*
136     (
137     ( page ( active-page ) )
138     ( cont ( page-contents page ) )
139     ( attrs ( filter attribute? cont ) )
140     ( cmap ( display-color-map ) )
141     ( sym #f )
142     ( txt #f )
143     )
144 
145     ( define ( color-valid? sym )
146         ( assoc-ref cmap sym )
147     )
148 
149     ( define ( color-val sym )
150         ( list-ref (assoc-ref cmap sym) 0 )
151     )
152 
153     ( define ( color-sym cname )
154         ( eval-string (format #f "'~a" cname) )
155     )
156 
157     ( define ( color-ndx sym )
158         ( color-map-name-to-index sym )
159     )
160 
161     ( define ( mk-str name ndx val )
162         ( format #f "~a=~d: ~a = ~a" name ndx name val )
163     )
164 
165 
166     ( undo-save-state )
167 
168     ( for-each
169     ( lambda ( attr )
170         ( set! sym ( color-sym (attrib-name attr) ) )
171         ( when ( and (color-valid? sym) (not (attrib-attachment attr)) )
172             ; ( format #t "[~a]~%" ( mk-str sym (color-ndx sym) (color-val sym) ) )
173             ( set! txt ( mk-str sym (color-ndx sym) (color-val sym) ) )
174             ( set-text-string! attr txt )
175         )
176     )
177       attrs
178     )
179 
180 ) ; let
181 ) ; cstst-up()
182