diff options
| -rw-r--r-- | NEWS | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/package/Makefile.am | 4 | ||||
| -rw-r--r-- | src/guile/skribilo/package/eq.scm | 276 |
3 files changed, 281 insertions, 1 deletions
diff --git a/NEWS b/NEWS index 7257a87..e9b5c33 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ New in Skribilo 1.2 (compared to Skribe 1.2d) * New engine: Lout (see http://lout.sf.net/). + * New package `eq' for equation formatting. + * New markups: `~', `numref', `!lout', `lout-illustration'. * Extended markups: `footnote' now takes a `:label' option. diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am index 6e047d3..781b1aa 100644 --- a/src/guile/skribilo/package/Makefile.am +++ b/src/guile/skribilo/package/Makefile.am @@ -1,4 +1,6 @@ guilemoduledir = $(GUILE_SITE)/skribilo/package dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ lncs.scm scribe.scm sigplan.scm skribe.scm \ - slide.scm web-article.scm web-book.scm + slide.scm web-article.scm web-book.scm \ + eq.scm + diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm new file mode 100644 index 0000000..1ac8d35 --- /dev/null +++ b/src/guile/skribilo/package/eq.scm @@ -0,0 +1,276 @@ +;;; eq.scm -- An equation formatting package. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo package eq) + :autoload (skribilo ast) (markup?) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo module) + :use-module (skribilo skribe utils) ;; `the-options', etc. + :use-module (ice-9 optargs)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This package defines a set of markups for formatting equations. The user +;;; may either use the standard Scheme prefix notation to represent +;;; equations, or directly use the specific markups (which looks more +;;; verbose). +;;; +;;; FIXME: This is incomplete. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Utilities. +;;; + +(define %operators + '(/ * + - = != ~= < > <= >= sqrt expt sum product)) + +(define %rebindings + (map (lambda (sym) + (list sym (symbol-append 'eq: sym))) + %operators)) + + +(define (eq:symbols->strings equation) + "Turn symbols located in non-@code{car} positions into strings." + (cond ((list? equation) + (if (or (null? equation) (null? (cdr equation))) + equation + (cons (car equation) ;; XXX: not tail-recursive + (map eq:symbols->strings (cdr equation))))) + ((symbol? equation) + (symbol->string equation)) + (else equation))) + +(define-public (eq-evaluate equation) + "Evaluate @var{equation}, an sexp (list) representing an equation, e.g. +@code{'(+ a (/ b 3))}." + (eval `(let ,%rebindings ,(eq:symbols->strings equation)) + (current-module))) + + +;;; +;;; Markup. +;;; + +(define-markup (eq :rest opts :key (ident #f) (class "eq")) + (new markup + (markup 'eq) + (ident (or ident (symbol->string (gensym "eq")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + result + (loop (cdr body) + (if (markup? (car body)) + (car body) ;; the `eq:*' markups were used + ;; directly + (eq-evaluate (car body))) ;; a quoted list was + ;; passed + )))))) + +(define-simple-markup eq:/) +(define-simple-markup eq:*) +(define-simple-markup eq:+) +(define-simple-markup eq:-) + +(define-simple-markup eq:=) +(define-simple-markup eq:!=) +(define-simple-markup eq:~=) +(define-simple-markup eq:<) +(define-simple-markup eq:>) +(define-simple-markup eq:>=) +(define-simple-markup eq:<=) + +(define-simple-markup eq:sqrt) +(define-simple-markup eq:expt) + +(define-markup (eq:sum :rest opts :key (ident #f) (class "eq:sum") + (from #f) (to #f)) + (new markup + (markup 'eq:sum) + (ident (or ident (symbol->string (gensym "eq:sum")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:product :rest opts :key (ident #f) (class "eq:product") + (from #f) (to #f)) + (new markup + (markup 'eq:product) + (ident (or ident (symbol->string (gensym "eq:product")))) + (options (the-options opts)) + (body (the-body opts)))) + + + +;;; +;;; Lout implementation +;;; + +(let ((lout (find-engine 'lout))) + (if (not lout) + (skribe-error 'eq "Lout engine not found" lout) + (let ((includes (engine-custom lout 'includes))) + ;; Append the `eq' include file + (engine-custom-set! lout 'includes + (string-append includes "\n" + "@SysInclude { eq }\n"))))) + +;; FIXME: Reimplement the `symbol' writer so that `@Sym' is not used within +;; equations (e.g. output `alpha' instead of `{ @Sym alpha }'). + +(markup-writer 'eq (find-engine 'lout) + :before "\n@Eq { " + :action (lambda (node engine) + (let ((eq (markup-body node))) + ;(fprint (current-error-port) "eq=" eq) + (output eq engine))) + :after " }\n") + + +;; +;; `+' and `-' have lower precedence than `*', `/', `=', etc., so their +;; operands do not need to be enclosed in braces. +;; + +(markup-writer 'eq:+ (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + ;; no braces + (output (car operands) engine) + (if (pair? (cdr operands)) + (display " + ")) + (loop (cdr operands))))))) + +(markup-writer 'eq:- (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + ;; no braces + (output (car operands) engine) + (if (pair? (cdr operands)) + (display " - ")) + (loop (cdr operands))))))) + +(define-macro (simple-lout-markup-writer sym . lout-name) + `(markup-writer ',(symbol-append 'eq: sym) + (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + (display " { ") + (output (car operands) engine) + (display " }") + (if (pair? (cdr operands)) + (display ,(string-append " " + (if (null? lout-name) + (symbol->string sym) + (car lout-name)) + " "))) + (loop (cdr operands)))))))) + +(simple-lout-markup-writer * "times") +(simple-lout-markup-writer / "over") +(simple-lout-markup-writer =) +(simple-lout-markup-writer <) +(simple-lout-markup-writer >) +(simple-lout-markup-writer <=) +(simple-lout-markup-writer >=) + +(markup-writer 'eq:expt (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (begin + (display " { { ") + (output (car body) engine) + (display " } sup { ") + (output (cadr body) engine) + (display " } } ")) + (skribe-error 'eq:expt "wrong number of arguments" + body))))) + + +;;; +;;; Sums, products, integrals, etc. +;;; + +(define-macro (range-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to)) + (body (markup-body node))) + (display ,(string-append " { big " lout-name + " from { ")) + (output from engine) + (display " } to { ") + (output to engine) + (display " } { ") + (output body engine) + (display " } "))))) + +(range-lout-markup-writer sum "sum") +(range-lout-markup-writer product "prod") + + + +;;; +;;; Text-only implementation. +;;; + +(markup-writer 'eq (find-engine 'base) + :action (lambda (node engine) + (output (apply it (markup-body node)) engine))) + +(markup-writer 'eq:/ (find-engine 'base) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + (display " ") + (output (car operands) engine) + (display " ") + (if (pair? (cdr operands)) + (display " / ")) + (loop (cdr operands))))))) + +;;; arch-tag: 58764650-2684-47a6-8cc7-6288f2b474da + +;;; eq.scm ends here |