1 ; file: select-locked.scm
  2 ; type: lepton-schematic Guile script
  3 ; version: 1.3
  4 ; copyright (c) 2020 dmn <graahnul.grom@gmail.com>
  5 ; license: GPLv2+
  6 ;
  7 ; Extends lepton-schematic functionality by providing
  8 ; keyboard shortcuts to select locked objects.
  9 ;
 10 ; - Ctrl+Shift+L: select all locked components
 11 ; - Shift+L:      select next locked component
 12 ; - Ctrl+L:       select locked component under the mouse cursor
 13 ;
 14 ; Usage:
 15 ; Type in the ":" prompt or add this to your gschemrc file:
 16 ;   ( primitive-load "/path/to/select-locked.scm" )
 17 ;
 18 ; It's possible to use different keyboard shortcuts. Add the
 19 ; following to the gschemrc file and modify key definitions:
 20 ;
 21 ; ( global-set-key "<Control><Shift>L" 'select-locked-all )
 22 ; ( global-set-key "<Shift>L"          'select-locked-next )
 23 ; ( global-set-key "<Control>L"        'select-locked-under-mouse )
 24 ;
 25 
 26 ; Replace "#t" with "#f" to get less verbose log messages:
 27 ;
 28 ( define verbose #t )
 29 
 30 
 31 
 32 ; no user serviceable parts below:
 33 
 34 ( use-modules ( srfi srfi-1 ) ) ; find()
 35 ( use-modules ( lepton page ) )
 36 ( use-modules ( lepton object ) )
 37 ( use-modules ( lepton attrib ) )
 38 ( use-modules ( lepton log ) )
 39 ( use-modules ( lepton config ) )
 40 ( use-modules ( schematic window ) )
 41 ( use-modules ( schematic selection ) )
 42 ( use-modules ( schematic gui keymap ) )
 43 
 44 
 45 
 46 ; private:
 47 ;
 48 ( define ( locked-comps )
 49 
 50   ( define ( locked-comp? obj )
 51     ( and
 52       ( component? obj )
 53       ( not (object-selectable? obj) )
 54     )
 55   )
 56 
 57 
 58   ; return:
 59   ( filter locked-comp? (page-contents (active-page)) )
 60 
 61 ) ; locked-comps()
 62 
 63 
 64 
 65 ; private:
 66 ;
 67 ( define ( deselect-all )
 68   ( for-each deselect-object! (page-contents (active-page)) )
 69 )
 70 
 71 
 72 
 73 ; private:
 74 ;
 75 ( define ( select-comp comp )
 76   ( select-object! comp )
 77   ( for-each select-object! (object-attribs comp) )
 78 )
 79 
 80 
 81 
 82 
 83 ; public:
 84 ;
 85 ( define ( select-locked-all )
 86 ( let
 87   (
 88   ( comps ( locked-comps ) )
 89   )
 90 
 91   ( unless ( null? comps )
 92     ( deselect-all )
 93     ( for-each select-comp comps )
 94   )
 95 
 96   ( if ( null? comps )
 97     ( log! ; if
 98       'message
 99       "select-locked: no locked components found"
100     )
101     ( log! ; else
102       'message
103       "select-locked: ~a locked component(s) selected~a"
104       ( length comps )
105       ( if verbose ". press <E Shift+L> to unlock" "" )
106     )
107   )
108 
109 
110 ) ; let
111 ) ; select-locked-all()
112 
113 
114 
115 
116 ; public:
117 ;
118 ( define ( select-locked-next )
119 ( let*
120   (
121   ( comps ( locked-comps ) )
122   ( len   ( length comps ) )
123   ( sel   ( page-selection (active-page) ) )
124   ( ndx   0 )
125   ( comp #f )
126   )
127 
128   ; helper functions:
129 
130   ( define ( print-msg i c ) ; i: index, c: component
131     ( log! 'message
132       "select-locked: ~a of ~a (~a)~a"
133       ( 1+ i )
134       len
135       ( component-basename c )
136       ( if verbose
137         ". press <E E> to edit, <E Shift+L> to unlock" ; if
138         ""                                             ; else
139       )
140     )
141   )
142 
143 
144   ( define ( next-ndx i )
145     ; return:
146     ( if ( = i (1- len) )
147       0        ; if
148       ( 1+ i ) ; else
149     )
150   )
151 
152   ( define ( locked-obj? obj )
153     ; return:
154     ( not (object-selectable? obj) )
155   )
156 
157 
158   ( define ( go? c )
159     ; return:
160     ( or
161       ( null? sel )                  ; nothing selected
162       ( not (find locked-obj? sel) ) ; no locked comps selected
163       ( object-selected? c )         ; locked comp c selected
164     )
165   )
166 
167   ; function's body:
168 
169   ( when ( null? comps )
170     ( log! 'message "select-locked: no locked components found" )
171   )
172 
173   ( while ( < ndx len )
174     ( set! comp ( list-ref comps ndx ) )
175 
176     ( when ( go? comp )
177       ( deselect-all )
178       ( set! comp (list-ref comps (next-ndx ndx) ) )
179       ( select-comp comp )
180       ( print-msg ndx comp )
181       ( break )
182     )
183 
184     ( set! ndx (1+ ndx) )
185   )
186 
187 ) ; let
188 ) ; select-locked-next()
189 
190 
191 
192 
193 ; private:
194 ; see liblepton/src/geda_component_object.c:
195 ;     create_placeholder_small()
196 ;
197 ( define ( placeholder-bounds-small c )
198 ( let*
199   (
200   ( pt ( component-position c ) )
201   ( x ( car pt ) )
202   ( y ( cdr pt ) )
203   ( bounds1 ( cons (cons x (+ y 50)) (cons (+ x 50) y) ) )
204   ( str ( component-basename c ) )
205   ( txt
206     ( make-text
207       (cons (+ x 100) (+ y 100)) 'lower-left 0 str 6 #t 'both ) )
208   ( bounds2 ( object-bounds txt ) )
209   )
210 
211   ; return:
212   ( fold-bounds bounds1 bounds2 )
213 
214 ) ; let
215 ) ; placeholder-bounds-small()
216 
217 
218 ; private:
219 ; see liblepton/src/geda_component_object.c:
220 ;     create_placeholder_classic()
221 ;
222 ( define ( placeholder-bounds-big c )
223 ( let*
224   (
225   ( pt ( component-position c ) )
226   ( x ( car pt ) )
227   ( y ( cdr pt ) )
228   ( bounds1 ( cons (cons x (+ y 100)) (cons (+ x 100) y) ) )
229   ( str
230     ( format #f "Component not found:\n~a" (component-basename c) ) )
231   ( txt
232     ( make-text
233       (cons (+ x 100) (+ y 100)) 'lower-left 0 str 8 #t 'both ) )
234   ( bounds2 ( object-bounds txt ) )
235   ( b2-top-left  ( car bounds2 ) )
236   ( b2-bot-right ( cdr bounds2 ) )
237   ( x1 ( car b2-top-left ) )
238   ( x2 ( car b2-bot-right ) )
239   ( dx ( / (- x2 x1) 4 ) )
240   ( y1 ( cdr b2-top-left ) )
241   ( dy 100 )
242   ( triangle-top-left  ( cons (+ x1 dx) (+ y1 dy 500) ) )
243   ( triangle-bot-right ( cons (+ x1 dx 600) (+ y1 dy) ) )
244   ( bounds3 ( cons triangle-top-left triangle-bot-right ) )
245   )
246 
247   ; [debug]:
248   ; ( page-append! (active-page)
249     ; ( make-box (car bounds1) (cdr bounds1) ) )
250   ; ( page-append! (active-page)
251     ; ( make-box (car bounds2) (cdr bounds2) ) )
252   ; ( page-append! (active-page)
253     ; ( make-box (car bounds3) (cdr bounds3) ) )
254   ; ( bb ( fold-bounds bounds1 bounds2 bounds3 ) )
255   ; ( page-append! (active-page) (make-box (car bb) (cdr bb)) )
256 
257   ; return:
258   ( fold-bounds bounds1 bounds2 bounds3 )
259 
260 ) ; let
261 ) ; placeholder-bounds-big()
262 
263 
264 ; private:
265 ;
266 ( define ( placeholder-bounds c )
267 ( let*
268   (
269   ( cfg ( path-config-context (getcwd) ) )
270   ( small #t )
271   )
272 
273   ( catch #t
274     ( lambda()
275       ( set! small
276         ( config-boolean cfg "schematic.gui" "small-placeholders" )
277       )
278     )
279     ( lambda( ex . args )
280       ( log! 'message
281         "select-locked: assuming small placeholders used" )
282     )
283   )
284 
285   ; return:
286   ( if small
287     ( placeholder-bounds-small c ) ; if
288     ( placeholder-bounds-big c )   ; else
289   )
290 
291 ) ; let
292 ) ; placeholder-bounds()
293 
294 
295 
296 
297 ; public:
298 ;
299 ( define ( select-locked-under-mouse )
300 
301   ; helper functions:
302 
303   ( define ( point-in-bounds? pt bounds )
304   ( let*
305     (
306     ( top-left  ( car bounds ) )
307     ( bot-right ( cdr bounds ) )
308     ( x1  ( car top-left ) )
309     ( x2  ( car bot-right ) )
310     ( y1  ( cdr bot-right ) )
311     ( y2  ( cdr top-left ) )
312     ( ptx ( car pt ) )
313     ( pty ( cdr pt ) )
314     )
315 
316     ; return:
317     ( and
318       ( >= ptx x1 ) ( <= ptx x2 )
319       ( >= pty y1 ) ( <= pty y2 )
320     )
321 
322   ) ; let
323   ) ; point-in-bounds?()
324 
325 
326   ( define ( comp-contents c ) ; {pre}: [c] is not a placeholder
327     ( define ( non-txt-obj? o )
328         ( not (text? o) )
329     )
330   ( let*
331     (
332     ( cc ( component-contents c ) )
333     ( oo ( filter non-txt-obj? cc ) )
334     )
335 
336     ; return:
337     ( if ( null? oo )
338       cc ; if
339       oo ; else
340     )
341 
342   ) ; let
343   ) ; comp-contents()
344 
345 
346   ( define ( placeholder? c )
347     ( null? (component-contents c) )
348   )
349 
350 
351   ( define ( comp-bounds c )
352     ; return:
353     ( if ( placeholder? c )
354       ( placeholder-bounds c ) ; if
355       ( apply fold-bounds      ; else
356         ( map object-bounds (comp-contents c) ) )
357     )
358   )
359 
360 
361   ( define ( comp-area c )
362   ( let*
363     (
364     ( bounds    ( comp-bounds c ) )
365     ( top-left  ( car bounds ) )
366     ( bot-right ( cdr bounds ) )
367     ( x1 ( car top-left ) )
368     ( x2 ( car bot-right ) )
369     ( y1 ( cdr bot-right ) )
370     ( y2 ( cdr top-left ) )
371     )
372 
373     ; return:
374     ( * (- x2 x1) (- y2 y1) )
375 
376   ) ; let
377   ) ; comp-area()
378 
379 
380   ( define ( less-area? c1 c2 )
381     ( < (comp-area c1) (comp-area c2) )
382   )
383 
384 
385   ( define ( comp-under-mouse? c )
386     ; return:
387     ( if ( and (pointer-position) (comp-bounds c) )
388       ( point-in-bounds? (pointer-position) (comp-bounds c) ) ; if
389       #f                                                      ; else
390     )
391   )
392 
393 
394   ; function's body:
395 
396 ( let*
397   (
398   ;
399   ; - sort => the smallest will be found first, and not e.g. title
400   ;
401   ( comps ( sort (locked-comps) less-area? ) )
402   ( comp  ( find comp-under-mouse? comps ) )
403   )
404 
405   ( deselect-all )
406 
407   ( if comp
408     ( select-comp comp ) ; if
409     ( log! 'message      ; else
410       "select-locked: no locked components under mouse" )
411   )
412 
413 ) ; let
414 ) ; select-locked-under-mouse()
415 
416 
417 
418 
419 ; top-level code:
420 ;
421 ( global-set-key "<Control><Shift>L" 'select-locked-all )
422 ( global-set-key "<Shift>L"          'select-locked-next )
423 ( global-set-key "<Control>L"        'select-locked-under-mouse )
424 
425 
426 ; vim: ft=scheme tabstop=2 softtabstop=2 shiftwidth=2 expandtab
427