gschem/scheme/gschem.scm

   1 ;;; gEDA - GPL Electronic Design Automation
   2 ;;; gschem - gEDA Schematic Capture
   3 ;;; Copyright (C) 1998-2007 Ales Hvezda
   4 ;;; Copyright (C) 1998-2007 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20
  21 ; guile 1.4/1.6 compatibility:  Define an eval-in-currentmodule procedure
  22 ; If this version of guile has an R5RS-compatible eval (that requires a
  23 ; second argument specfying the environment), and a current-module function
  24 ; (like 1.6) use them to define eval-cm. else define eval-cm to eval (for 1.4)
  25 (if (false-if-exception (eval 'display (current-module)))
  26     (define (eval-cm exp) (eval exp (current-module)))
  27     (define eval-cm eval))
  28
  29 (define last-command-sequence #f)
  30 (define current-command-sequence '())
  31
  32 ; no action hotkey
  33 (define no-action
  34   (lambda ()
  35       #f
  36   )
  37 )
  38
  39 ; Doers
  40 (define (press-key key)
  41   (eval-pressed-key current-keymap key))
  42
  43 (define (eval-pressed-key keymap key)
  44   (and keymap
  45        (let ((lookup (assoc key keymap)))
  46          (cond ((pair? lookup)
  47                 (if (not (equal? 'repeat-last-command (cdr lookup)))
  48                     (set! current-command-sequence
  49                           (cons key current-command-sequence)))
  50                 (perform-action (cdr lookup)))
  51                (else
  52                 (set! current-keymap global-keymap)
  53                 ;(display "No keymap found")
  54                 ;(newline)
  55                 #f
  56                 )))))
  57
  58 (define (perform-action action)
  59     (let ((local-action (eval-cm action)))
  60       (cond ((list? local-action)
  61              (set! current-keymap local-action))
  62             ((equal? 'repeat-last-command action)
  63              (repeat-last-command))
  64             (else
  65              (set! last-command-sequence current-command-sequence)
  66              (set! current-command-sequence '())
  67              (local-action)
  68              (set! current-keymap global-keymap)))))
  69
  70 (define (repeat-last-command)
  71   ;; need to `reverse' because the sequence was "push"ed initially
  72   ;(display last-command-sequence)
  73   ;(newline)
  74   (and last-command-sequence
  75        (not (null? last-command-sequence))
  76        (for-each press-key (reverse last-command-sequence))))
  77
  78 (define (eval-stroke stroke)
  79   (let ((action (assoc stroke strokes)))
  80     (cond ((not action)
  81 ;           (display "No such stroke\n")
  82 ;          (display stroke)
  83            #f)
  84           (else
  85 ;           (display "Scheme found action ")
  86 ;           (display action)
  87 ;           (display "\n")
  88            ((eval-cm (cdr action)))
  89            #t))))
  90
  91
  92 ;; Search the keymap for a particular scheme function and return the keys
  93 ;; which execute this hotkey
  94 (define foundkey "")
  95 (define temp "")
  96
  97 (define find-key-lowlevel
  98   (let ((keys '()))
  99     (lambda (keymap function)
 100       (for-each
 101        (lambda (mapped-key) ; Receives a pair
 102          (if (list? (eval-cm (cdr mapped-key)))
 103              (begin
 104                (set! temp (car mapped-key))
 105                (find-key-lowlevel (eval-cm (cdr mapped-key)) function)
 106                (set! temp "")
 107                )
 108              (if (eq? (cdr mapped-key) function)
 109                  (set! foundkey (string-append temp (car mapped-key)))
 110
 111                  )
 112              )
 113          )
 114        keymap))))
 115
 116 (define find-key
 117   (lambda(function)
 118     (set! temp "")
 119     (set! foundkey "")
 120 ;;    (display function) (newline)
 121     (find-key-lowlevel global-keymap function)
 122     (if (eq? (string-length foundkey) 0)
 123         #f
 124         foundkey
 125         )
 126     ))
 127
 128 ;; Printing out current key bindings for gEDA (gschem)
 129
 130 (define (dump-current-keymap)
 131   (dump-keymap global-keymap))
 132
 133 (use-modules (srfi srfi-13))
 134 (define (dump-keymap keymap)
 135   (let loop ((keymap keymap)
 136              (keys   '()))
 137     (if (null? keymap)
 138         '()
 139         (let* ((entry  (car keymap))
 140                (key    (car entry))
 141                (action (eval-cm (cdr entry))))
 142           (cond ((list? action)
 143                  (append (loop action (cons key keys))
 144                          (loop (cdr keymap) keys)))
 145                 (else
 146                  (cons (cons (cdr entry)
 147                              (string-join (reverse (cons key keys)) " "))
 148                        (loop (cdr keymap) keys))))))))