plugins/guile/gnumeric_startup.scm

   1 ; -*- scheme -*-
   2 ;
   3 ; Gnumeric Guile plug-in system startup file
   4 ;
   5 ; Mark Probst (schani@unix.cslab.tuwien.ac.at)
   6 ;
   7
   8 ;(display "Guile plug-in initializing\n")
   9 (load "functions.scm")
  10
  11 ;; Error handling
  12 ;; This function is from gnucash, but simplified
  13 (define (gnm:error->string tag args)
  14   (define (write-error port)
  15     (false-if-exception
  16      (apply display-error (fluid-ref the-last-stack) port args))
  17     (force-output port))
  18     (false-if-exception
  19      (call-with-output-string write-error)))
  20
  21 ; cell-refs
  22 (define (make-cell-ref col row)
  23   (if (and (number? col) (number? row))
  24       (cons 'cell-ref (cons col row))
  25       '()))
  26
  27 (define (cell-ref? ob)
  28   (and (pair? ob) (eq? (car ob) 'cell-ref)))
  29
  30 (define cell-ref-col cadr)
  31
  32 (define cell-ref-row cddr)
  33
  34 ; vars
  35 (define (make-var cell-ref)
  36   (cons 'var cell-ref))
  37
  38 (define (var? ob)
  39   (and (pair? ob) (eq? (car ob) 'var)))
  40
  41 (define var-cell-ref cdr)
  42
  43 ; operators
  44 (define binary-operator? '())
  45 (define binary-operator-name '())
  46 (define binary-operator-function '())
  47 (let ((binary-op-names
  48        (list (cons '= "=")
  49              (cons '> ">")
  50              (cons '< "<")
  51              (cons '>= ">=")
  52              (cons '<= "<=")
  53              (cons '<> "<>")
  54              (cons '+ "+")
  55              (cons '- "-")
  56              (cons '* "*")
  57              (cons '/ "/")
  58              (cons 'expt "^")
  59              (cons 'string-append "&")))
  60       (binary-op-funcs
  61        (list (cons '= =)
  62              (cons '> >)
  63              (cons '< <)
  64              (cons '>= >=)
  65              (cons '<= <=)
  66              (cons '<> (lambda (n1 n2) (not (= n1 n2))))
  67              (cons '+ +)
  68              (cons '- -)
  69              (cons '* *)
  70              (cons '/ /)
  71              (cons 'expt expt)
  72              (cons 'string-append string-append))))
  73
  74   (set! binary-operator?
  75         (lambda (op)
  76           (if (assq op binary-op-names) #t #f)))
  77
  78   (set! binary-operator-name
  79         (lambda (op)
  80           (cdr (assq op binary-op-names))))
  81
  82   (set! binary-operator-function
  83         (lambda (op)
  84           (cdr (assq op binary-op-funcs)))))
  85
  86 ; exprs
  87 ;; this should really be coded in C
  88 (define (unparse-expr expr)
  89   (define (unparse-subexpr expr)
  90     (cond ((number? expr)
  91            (number->string expr))
  92           ((string? expr)
  93            (string-append "\"" expr "\"")) ; FIXME: should also quote "'s inside
  94           ((var? expr)
  95            (let ((cell-ref (var-cell-ref expr)))
  96              (string-append
  97               (string (integer->char (+ (char->integer #\A) (cell-ref-col cell-ref)))) ; FIXME: this only works if col < 26
  98               (number->string (+ (cell-ref-row cell-ref) 1)))))
  99           ((list? expr)
 100            (let ((op (car expr)))
 101              (cond ((binary-operator? op)
 102                     (string-append "("
 103                                    (unparse-subexpr (cadr expr))
 104                                    (binary-operator-name op)
 105                                    (unparse-subexpr (caddr expr))
 106                                    ")"))
 107                    ((eq? op 'neg)
 108                     (string-append "-(" (unparse-subexpr (cadr expr)) ")"))
 109                    ((eq? op 'funcall)
 110                     (string-append (cadr expr) "()"))   ; FIXME: should unparse args
 111                    (else
 112                     "ERROR"))))
 113           (else
 114            "ERROR")))
 115
 116   (string-append "=" (unparse-subexpr expr)))
 117
 118 ;; this should also be coded in C
 119 (define (eval-expr expr)
 120   (define (eval-expr-list expr-list)
 121     (if (null? expr-list)
 122         '()
 123         (cons (eval-expr (car expr-list)) (eval-expr-list (cdr expr-list)))))
 124
 125   (cond ((number? expr) expr)
 126         ((string? expr) expr)
 127         ((var? expr) (cell-value (var-cell-ref expr)))
 128         ((list? expr)
 129          (let ((op (car expr)))
 130            (cond ((binary-operator? op)
 131                   ((binary-operator-function op) (eval-expr (cadr expr)) (eval-expr (caddr expr))))
 132                  ((eq? op 'neg)
 133                   (- (eval-expr (cadr expr))))
 134                  ((eq? op 'funcall)
 135                   (gnumeric-funcall (cadr expr) (eval-expr-list (caddr expr))))
 136                  (else
 137                   "ERROR"))))
 138         (else
 139          "ERROR")))
 140
 141
 142
 143 ; symbolic differentiation with immediate evaluation
 144 ;; in case of a funcall this should do numeric differentiation
 145 (define (differentiate expr var)
 146   (cond ((number? expr) 0)
 147         ((var? expr)
 148          (let ((cell-ref (var-cell-ref expr)))
 149            (if (equal? var cell-ref)
 150                1
 151                (differentiate (cell-expr cell-ref) var))))
 152         ((list? expr)
 153          (let ((op (car expr)))
 154            (cond ((binary-operator? op)
 155                   (let ((left-arg (cadr expr))
 156                         (right-arg (caddr expr)))
 157                     (cond ((eq? op '+)
 158                            (+ (differentiate left-arg var) (differentiate right-arg var)))
 159                           ((eq? op '-)
 160                            (- (differentiate left-arg var) (differentiate right-arg var)))
 161                           ((eq? op '*)
 162                            (+ (* (eval-expr left-arg) (differentiate right-arg var))
 163                               (* (eval-expr right-arg) (differentiate left-arg var))))
 164                           ((eq? op '/)
 165                            (let ((v (eval-expr right-arg)))
 166                              (/ (- (* (differentiate left-arg var) v)
 167                                    (* (differentiate right-arg var) (eval-expr left-arg)))
 168                                 (* v v))))
 169                           ((eq? op 'expt)
 170                            (let ((u (eval-expr left-arg))
 171                                  (v (eval-expr right-arg))
 172                                  (du (differentiate left-arg var))
 173                                  (dv (differentiate right-arg var)))
 174                              (+ (* (expt u (- v 1)) v du) (* (expt u v) (log u) dv))))
 175                           (else
 176                            "ERROR"))))
 177                  ((eq? op 'neg)
 178                   (- (differentiate (cadr expr) var)))
 179                  (else
 180                   "ERROR"))))
 181         (else
 182          "ERROR")))
 183
 184 ; a little expression simplifier and constant folder
 185 (define (simplify-expr expr)
 186   (define (constant? expr)
 187     (or (number? expr) (string? expr)))
 188
 189   (cond ((or (number? expr) (string? expr) (var? expr))
 190          expr)
 191         ((list? expr)
 192          (let ((op (car expr)))
 193            (cond ((binary-operator? op)
 194                   (let* ((left-arg (simplify-expr (cadr expr)))
 195                          (right-arg (simplify-expr (caddr expr)))
 196                          (new-expr (list op left-arg right-arg)))
 197                     (cond ((and (constant? left-arg) (constant? right-arg))
 198                            (eval-expr new-expr))
 199                           ((and (eq? op '+) (number? left-arg) (zero? left-arg))
 200                            right-arg)
 201                           ((and (or (eq? op '+) (eq? op '-)) (number? right-arg) (zero? right-arg))
 202                            left-arg)
 203                           ((and (eq? op '*) (number? left-arg) (= left-arg 1))
 204                            right-arg)
 205                           ((and (or (eq? op '*) (eq? op '/)) (number? right-arg) (= right-arg 1))
 206                            left-arg)
 207                           ((and (eq? op 'expt) (number? left-arg) (or (zero? left-arg) (= left-arg 1)))
 208                            left-arg)
 209                           ((and (eq? op 'expt) (number? right-arg) (= right-arg 1))
 210                            left-arg)
 211                           (else
 212                            new-expr))))
 213                  ((eq? op 'neg)
 214                   (let* ((arg (simplify-expr (cadr expr)))
 215                          (new-expr (list op arg)))
 216                     (if (constant? arg)
 217                         (eval-expr new-expr)
 218                         new-expr)))
 219                  (else
 220                   expr))))              ; should also handle functions without side effects
 221         (else
 222          expr)))
 223
 224 ; load user init-file if present
 225 (let ((home-gnumericrc (string-append (getenv "HOME") "/.gnumeric/guile.scm")))
 226   (if (access? home-gnumericrc R_OK)
 227       (load home-gnumericrc)))
 228
 229 ;(display "Guile plug-in initialization complete\n")
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239