gschem/scheme/gschem.scm

   1 ;;; gEDA - GPL Electronic Design Automation
   2 ;;; gschem - gEDA Schematic Capture
   3 ;;; Copyright (C) 1998-2010 Ales Hvezda
   4 ;;; Copyright (C) 1998-2020 gEDA Contributors (see ChangeLog for details)
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 2 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  19 ;;; MA 02111-1301 USA.
  20
  21 (use-modules (gschem keymap)
  22              (gschem action)
  23              (gschem core gettext)
  24              (gschem core builtins)
  25              (gschem builtins)
  26              (gschem window)
  27              (srfi srfi-1))
  28
  29 ;; -------------------------------------------------------------------
  30 ;;;; Global keymaps and key dispatch logic
  31
  32 (define current-keys '())
  33
  34 (define %global-keymap (make-keymap))
  35 (define current-keymap %global-keymap)
  36
  37 ;; Set a global keybinding
  38 (define (global-set-key key binding)
  39   (bind-keys! %global-keymap key binding))
  40
  41 ;; Called from C code to evaluate keys.
  42 (define (press-key key)
  43   (eval-pressed-key current-keymap key))
  44
  45 ;; Function for resetting current key sequence
  46 (define (reset-keys) (set! current-keys '()) #f)
  47
  48 ;; Does the work of evaluating a key.  Adds the key to the current key
  49 ;; sequence, then looks up the key sequence in the current keymap.  If
  50 ;; the key sequence resolves to an action, calls the action.  If the
  51 ;; key sequence can be resolved to an action, returns #t; if it
  52 ;; resolves to a keymap (i.e. it's a prefix key), returns the "prefix"
  53 ;; symbol; otherwise, returns #f.  If the key is #f, clears the
  54 ;; current key sequence.
  55 (define (eval-pressed-key keymap key)
  56   (if key
  57       (begin
  58         ;; Add key to current key sequence
  59         (set! current-keys (cons key current-keys))
  60         (let* ((keys (list->vector (reverse current-keys)))
  61                (bound (lookup-keys keymap keys)))
  62           (cond
  63            ;; Keys are a prefix -- do nothing successfully
  64            ((keymap? bound) 'prefix)
  65            ;; Keys are bound to something -- reset current key
  66            ;; sequence, then try to run the action
  67            (bound (begin
  68                     (reset-keys)
  69                     (eval-action-at-point! bound)))
  70            ;; No binding
  71            (else (reset-keys)))))
  72
  73       (reset-keys)))
  74
  75
  76 (define (eval-stroke stroke)
  77   (let ((action (assoc stroke strokes)))
  78     (cond ((not action)
  79 ;           (display "No such stroke\n")
  80 ;          (display stroke)
  81            #f)
  82           (else
  83 ;           (display "Scheme found action ")
  84 ;           (display action)
  85 ;           (display "\n")
  86            (eval-action! (cdr action))
  87            #t))))
  88
  89 ;; Search the global keymap for a particular symbol and return the
  90 ;; keys which execute this hotkey, as a string suitable for display to
  91 ;; the user. This is used by the gschem menu system.
  92 (define (find-key action)
  93   (let ((keys (lookup-binding %global-keymap action)))
  94     (and keys (keys->display-string keys))))
  95
  96 ;; Printing out current key bindings for gEDA (gschem)
  97 (define (%gschem-hotkey-store/dump-global-keymap)
  98   (dump-keymap %global-keymap))
  99
 100 (define (dump-keymap keymap)
 101
 102   ;; Use this to change "Page_Up" to "Page Up" (etc.)
 103   (define (munge-keystring str)
 104     (string-map (lambda (c) (case c ((#\_) #\ ) (else c))) str))
 105
 106   (define lst '())
 107
 108   (define (binding->entry prefix key binding)
 109     (let* ((keys (list->vector (reverse (cons key prefix))))
 110            (keystr (munge-keystring (keys->display-string keys))))
 111       (set! lst (cons (list binding keystr) lst))))
 112
 113   (define (build-dump! km prefix)
 114     (keymap-for-each
 115      (lambda (key binding)
 116        (cond
 117
 118         ((action? binding)
 119          (binding->entry prefix key binding))
 120
 121         ((keymap? binding)
 122          (build-dump! binding (cons key prefix)))
 123         (else (error "Invalid action ~S bound to ~S"
 124                      binding (list->vector (reverse (cons key prefix)))))))
 125      km))
 126
 127   (build-dump! keymap '())
 128   lst)
 129
 130
 131 ;; Define old keymapping callbacks.
 132 ;;
 133 ;; These are for compatibility only--don't use them, don't change the
 134 ;; Scheme names.
 135
 136 (define file-new-window &file-new-window)
 137 (define file-new &file-new)
 138 (define file-open &file-open)
 139 (define file-script &file-script)
 140 (define file-save &file-save)
 141 (define file-save-as &file-save-as)
 142 (define file-save-all &file-save-all)
 143 (define file-print &file-print)
 144 (define file-image &file-image)
 145 (define file-close-window &file-close-window)
 146 (define file-quit &file-quit)
 147 (define edit-undo &edit-undo)
 148 (define edit-redo &edit-redo)
 149 (define edit-select &edit-select)
 150 (define edit-select-all &edit-select-all)
 151 (define edit-deselect &edit-deselect)
 152 (define edit-copy &edit-copy)
 153 (define edit-mcopy &edit-mcopy)
 154 (define edit-move &edit-move)
 155 (define edit-delete &edit-delete)
 156 (define edit-rotate-90 &edit-rotate-90)
 157 (define edit-mirror &edit-mirror)
 158 (define edit-slot &edit-slot)
 159 (define edit-color &edit-properties)
 160 (define edit-edit &edit-edit)
 161 (define edit-text &edit-text)
 162 (define edit-lock &edit-lock)
 163 (define edit-unlock &edit-unlock)
 164 (define edit-linetype &edit-properties)
 165 (define edit-filltype &edit-properties)
 166 (define edit-pin-type &edit-properties)
 167 (define edit-translate &edit-translate)
 168 (define edit-invoke-macro &edit-invoke-macro)
 169 (define edit-embed &edit-embed)
 170 (define edit-unembed &edit-unembed)
 171 (define edit-update &edit-update)
 172 (define edit-show-hidden &edit-show-hidden)
 173 (define edit-find-text &edit-find-text)
 174 (define edit-show-text &edit-show-text)
 175 (define edit-hide-text &edit-hide-text)
 176 (define edit-autonumber &edit-autonumber)
 177
 178 (define clipboard-copy &clipboard-copy)
 179 (define clipboard-cut &clipboard-cut)
 180 (define clipboard-paste &clipboard-paste)
 181
 182 (define buffer-copy1 &buffer-copy1)
 183 (define buffer-copy2 &buffer-copy2)
 184 (define buffer-copy3 &buffer-copy3)
 185 (define buffer-copy4 &buffer-copy4)
 186 (define buffer-copy5 &buffer-copy5)
 187 (define buffer-cut1 &buffer-cut1)
 188 (define buffer-cut2 &buffer-cut2)
 189 (define buffer-cut3 &buffer-cut3)
 190 (define buffer-cut4 &buffer-cut4)
 191 (define buffer-cut5 &buffer-cut5)
 192 (define buffer-paste1 &buffer-paste1)
 193 (define buffer-paste2 &buffer-paste2)
 194 (define buffer-paste3 &buffer-paste3)
 195 (define buffer-paste4 &buffer-paste4)
 196 (define buffer-paste5 &buffer-paste5)
 197
 198 (define view-redraw &view-redraw)
 199 (define view-zoom-full &view-zoom-full)
 200 (define view-zoom-extents &view-zoom-extents)
 201 (define view-zoom-in &view-zoom-in)
 202 (define view-zoom-out &view-zoom-out)
 203 (define view-zoom-box &view-zoom-box)
 204 (define view-pan &view-pan)
 205 (define view-pan-left &view-pan-left)
 206 (define view-pan-right &view-pan-right)
 207 (define view-pan-up &view-pan-up)
 208 (define view-pan-down &view-pan-down)
 209 (define view-dark-colors &view-dark-colors)
 210 (define view-light-colors &view-light-colors)
 211 (define view-bw-colors &view-light-bw-colors)
 212 (define page-manager &page-manager)
 213 (define page-next &page-next)
 214 (define page-prev &page-prev)
 215 (define page-close &page-close)
 216 (define page-revert &page-revert)
 217 (define page-print &page-print)
 218 (define add-component &add-component)
 219 (define add-attribute &add-attribute)
 220 (define add-net &add-net)
 221 (define add-bus &add-bus)
 222 (define add-text &add-text)
 223 (define add-path &add-path)
 224 (define add-line &add-line)
 225 (define add-box &add-box)
 226 (define add-picture &add-picture)
 227 (define add-circle &add-circle)
 228 (define add-arc &add-arc)
 229 (define add-pin &add-pin)
 230 (define hierarchy-down-schematic &hierarchy-down-schematic)
 231 (define hierarchy-down-symbol &hierarchy-down-symbol)
 232 (define hierarchy-up &hierarchy-up)
 233 (define attributes-attach &attributes-attach)
 234 (define attributes-detach &attributes-detach)
 235 (define attributes-show-name &attributes-show-name)
 236 (define attributes-show-value &attributes-show-value)
 237 (define attributes-show-both &attributes-show-both)
 238 (define attributes-visibility-toggle &attributes-visibility-toggle)
 239 (define options-snap-size &options-options)
 240 (define options-scale-up-snap-size &options-scale-up-snap-size)
 241 (define options-scale-down-snap-size &options-scale-down-snap-size)
 242 (define options-action-feedback &options-action-feedback)
 243 (define options-grid &options-grid)
 244 (define options-snap &options-snap)
 245 (define options-rubberband &options-rubberband)
 246 (define options-magneticnet &options-magneticnet)
 247 (define options-show-log-window &options-show-log-window)
 248 (define options-show-coord-window &options-show-coordinates)
 249 (define help-about &help-about)
 250 (define help-hotkeys &help-hotkeys)
 251 (define cancel &cancel)