aboutsummaryrefslogtreecommitdiff
path: root/src/guile/skribilo/package/eq
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile/skribilo/package/eq')
-rw-r--r--src/guile/skribilo/package/eq/Makefile.am4
-rw-r--r--src/guile/skribilo/package/eq/lout.scm217
2 files changed, 221 insertions, 0 deletions
diff --git a/src/guile/skribilo/package/eq/Makefile.am b/src/guile/skribilo/package/eq/Makefile.am
new file mode 100644
index 0000000..c7b4f93
--- /dev/null
+++ b/src/guile/skribilo/package/eq/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package/eq
+dist_guilemodule_DATA = lout.scm
+
+## arch-tag: 3e816c9a-7989-4baa-b38b-a095a5428ba1
diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm
new file mode 100644
index 0000000..c487b85
--- /dev/null
+++ b/src/guile/skribilo/package/eq/lout.scm
@@ -0,0 +1,217 @@
+;;; lout.scm -- Lout implementation of the `eq' 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package eq lout)
+ :use-module (skribilo package eq)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (ice-9 optargs))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Initialization.
+;;;
+
+(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")))))
+
+
+;;;
+;;; Simple markup writers.
+;;;
+
+
+(markup-writer 'eq (find-engine 'lout)
+ :options '(:inline?)
+ :before "{ "
+ :action (lambda (node engine)
+ (display (if (markup-option node :inline?)
+ "@E { "
+ "@Eq { "))
+ (let ((eq (markup-body node)))
+ ;;(fprint (current-error-port) "eq=" eq)
+ (output eq engine)))
+ :after " } }")
+
+
+
+(define-macro (simple-lout-markup-writer sym . args)
+ (let* ((lout-name (if (null? args)
+ (symbol->string sym)
+ (car args)))
+ (parentheses? (if (or (null? args) (null? (cdr args)))
+ #t
+ (cadr args)))
+ (precedence (operator-precedence sym))
+
+ ;; Note: We could use `pmatrix' here but it precludes line-breaking
+ ;; within equations.
+ (open-par `(if need-paren? "{ @VScale ( }" ""))
+ (close-par `(if need-paren? "{ @VScale ) }" "")))
+
+ `(markup-writer ',(symbol-append 'eq: sym)
+ (find-engine 'lout)
+ :action (lambda (node engine)
+ (let loop ((operands (markup-body node)))
+ (if (null? operands)
+ #t
+ (let* ((op (car operands))
+ (eq-op? (equation-markup? op))
+ (need-paren?
+ (and eq-op?
+ (< (operator-precedence
+ (equation-markup-name->operator
+ (markup-markup op)))
+ ,precedence)))
+ (column (port-column
+ (current-output-port))))
+
+ ;; Work around Lout's limitations...
+ (if (> column 1000) (display "\n"))
+
+ (display (string-append " { "
+ ,(if parentheses?
+ open-par
+ "")))
+ (output op engine)
+ (display (string-append ,(if parentheses?
+ close-par
+ "")
+ " }"))
+ (if (pair? (cdr operands))
+ (display ,(string-append " "
+ lout-name
+ " ")))
+ (loop (cdr operands)))))))))
+
+
+;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their
+;; operands do not need to be enclosed in parentheses. OTOH, since we use a
+;; horizontal bar of `/', we don't need to parenthesize its arguments.
+
+
+(simple-lout-markup-writer +)
+(simple-lout-markup-writer * "times")
+(simple-lout-markup-writer - "-")
+(simple-lout-markup-writer / "over" #f)
+(simple-lout-markup-writer =)
+(simple-lout-markup-writer <)
+(simple-lout-markup-writer >)
+(simple-lout-markup-writer <=)
+(simple-lout-markup-writer >=)
+
+(define-macro (binary-lout-markup-writer sym lout-name)
+ `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((body (markup-body node)))
+ (if (= (length body) 2)
+ (let* ((first (car body))
+ (second (cadr body))
+ (parentheses? (equation-markup? first)))
+ (display " { { ")
+ (if parentheses? (display "("))
+ (output first engine)
+ (if parentheses? (display ")"))
+ (display ,(string-append " } " lout-name " { "))
+ (output second engine)
+ (display " } } "))
+ (skribe-error ,(symbol-append 'eq: sym)
+ "wrong number of arguments"
+ body))))))
+
+(binary-lout-markup-writer expt "sup")
+(binary-lout-markup-writer in "element")
+(binary-lout-markup-writer notin "notelement")
+
+(markup-writer 'eq:apply (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((func (car (markup-body node))))
+ (output func engine)
+ (display "(")
+ (let loop ((operands (cdr (markup-body node))))
+ (if (null? operands)
+ #t
+ (begin
+ (output (car operands) engine)
+ (if (not (null? (cdr operands)))
+ (display ", "))
+ (loop (cdr operands)))))
+ (display ")"))))
+
+
+
+;;;
+;;; 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")
+
+(markup-writer 'eq:script (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((body (markup-body node))
+ (sup (markup-option node :sup))
+ (sub (markup-option node :sub)))
+ (display " { { ")
+ (output body engine)
+ (display " } ")
+ (if sup
+ (begin
+ (display (if sub " supp { " " sup { "))
+ (output sup engine)
+ (display " } ")))
+ (if sub
+ (begin
+ (display " on { ")
+ (output sub engine)
+ (display " } ")))
+ (display " } "))))
+
+
+;;; arch-tag: 2a1410e5-977e-4600-b781-3d57f4409b35