Added the equation formatting package (unfinished, undocumented).

* src/guile/skribilo/package/eq.scm: New.  Taken from
  `lcourtes@laas.fr--2004-libre/skribe-eq--main--0.1--patch-2' and
  significantly improved.

* src/guile/skribilo/package/Makefile.am (dist_guilemodule_DATA): Added
  `eq.scm'.

* NEWS: Mention this new package.

git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-47

2 files changed, 279 insertions, 1 deletions

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