Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


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

1 files changed, 281 insertions, 0 deletions

diff --git a/skribe/doc/skr/manual.skr b/skribe/doc/skr/manual.skr
new file mode 100644
index 0000000..1982237
--- /dev/null
+++ b/skribe/doc/skr/manual.skr
@@ -0,0 +1,281 @@
+;*=====================================================================*/
+;*    serrano/prgm/project/skribe/doc/skr/manual.skr                   */
+;*    -------------------------------------------------------------    */
+;*    Author      :  Manuel Serrano                                    */
+;*    Creation    :  Mon Sep  1 11:24:19 2003                          */
+;*    Last change :  Mon Sep 13 19:18:48 2004 (serrano)                */
+;*    Copyright   :  2003-04 Manuel Serrano                            */
+;*    -------------------------------------------------------------    */
+;*    Skribe manuals and documentation pages style                     */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;*    Base configuration                                               */
+;*---------------------------------------------------------------------*/
+(let ((be (find-engine 'base)))
+   (markup-writer 'example be
+      :options '(:legend :number)
+      :action (lambda (n e)
+		 (let ((ident (markup-ident n))
+		       (number (markup-option n :number))
+		       (legend (markup-option n :legend)))
+		    (skribe-eval (mark ident) e)
+		    (skribe-eval (center
+				  (markup-body n)
+				  (if number (bold (format "Ex. ~a: " number)))
+				  legend)
+				 e)))))
+
+;*---------------------------------------------------------------------*/
+;*    html-browsing-extra ...                                          */
+;*---------------------------------------------------------------------*/
+(define (html-browsing-extra n e)
+   (let ((i1 (let ((m (find-markup-ident "Index")))
+		(and (pair? m) (car m))))
+	 (i2 (let ((m (find-markup-ident "markups-index")))
+		(and (pair? m) (car m)))))
+      (cond
+	 ((not i1)
+	  (skribe-error 'left-margin "Can't find section" "Index"))
+	 ((not i2)
+	  (skribe-error 'left-margin "Can't find chapter" "Standard Markups"))
+	 (else
+	  (table :width 100.
+	     :border 0
+	     :cellspacing 0 :cellpadding 0
+	     (tr (td :align 'left :valign 'top (bold "index:"))
+		(td :align 'right (ref :handle (handle i1) :text "Global")))
+	     (tr (td :align 'left :valign 'top (bold "markups:"))
+		(td :align 'right (ref :handle (handle i2) :text "Index")))
+	     (tr (td :align 'left :valign 'top (bold "extensions:"))
+		(td :align 'right (ref :url *skribe-dir-doc-url* 
+				     :text "Directory"))))))))
+
+;*---------------------------------------------------------------------*/
+;*    Html configuration                                               */
+;*---------------------------------------------------------------------*/
+(let* ((he (find-engine 'html))
+       (bd (markup-writer-get 'bold he)))
+   (markup-writer 'bold he
+		  :class 'api-proto-ident
+		  :before "<font color=\"red\">"
+		  :action (lambda (n e) (output n e bd))
+		  :after "</font>")
+   (engine-custom-set! he 'web-book-main-browsing-extra html-browsing-extra)
+   (engine-custom-set! he 'favicon "lambda.gif"))
+
+;*---------------------------------------------------------------------*/
+;*    LaTeX                                                            */
+;*---------------------------------------------------------------------*/
+(let* ((le (find-engine 'latex))
+       (opckg (engine-custom le 'usepackage))
+       (lpckg "\\usepackage{fullpage}\n\\usepackage{eurosym}\n")
+       (npckg (if (string? opckg)
+		  (string-append lpckg opckg)
+		  lpckg)))
+   (engine-custom-set! le 'documentclass "\\documentclass{book}")
+   (engine-custom-set! le 'usepackage npckg))
+
+;*---------------------------------------------------------------------*/
+;*    prgm ...                                                         */
+;*---------------------------------------------------------------------*/
+(define-markup (prgm #!rest opts #!key (language skribe) (line #f) (file #f) (definition #f))
+   (let* ((c (cond
+		((eq? language skribe) *prgm-skribe-color*)
+		((eq? language xml) *prgm-xml-color*)
+		(else *prgm-default-color*)))
+	  (sc (cond
+		 ((and file definition)
+		  (source :language language :file file :definition definition))
+		 (file
+		  (source :language language :file file))
+		 (else
+		  (source :language language (the-body opts)))))
+	  (pr (cond
+		 (line
+		  (prog :line line sc))
+		 (else
+		  (pre sc)))))
+      (center
+       (frame :margin 5 :border 0 :width *prgm-width*
+	      (color :margin 5 :width 100. :bg c pr)))))
+
+;*---------------------------------------------------------------------*/
+;*    disp ...                                                         */
+;*---------------------------------------------------------------------*/
+(define-markup (disp #!rest opts #!key (verb #f) (line #f) (bg *disp-color*))
+   (if (engine-format? "latex")
+       (if verb 
+	   (pre (the-body opts))
+	   (the-body opts))
+       (center
+	  (frame :margin 5 :border 0 :width *prgm-width*
+	     (color :margin 5 :width 100. :bg bg
+		(if verb 
+		    (pre (the-body opts))
+		    (the-body opts)))))))
+
+;*---------------------------------------------------------------------*/
+;*    keyword ...                                                      */
+;*---------------------------------------------------------------------*/
+(define-markup (keyword arg)
+   (new markup
+      (markup '&source-key)
+      (body (cond
+	       ((keyword? arg)
+		(keyword->string arg))
+	       ((symbol? arg)
+		(string-append ":" (symbol->string arg)))
+	       (else
+		arg)))))
+
+;*---------------------------------------------------------------------*/
+;*    param ...                                                        */
+;*---------------------------------------------------------------------*/
+(define-markup (param arg)
+   (cond
+      ((keyword? arg)
+       (keyword arg))
+      ((symbol? arg)
+       (code (symbol->string arg)))
+      (else
+       arg)))
+
+;*---------------------------------------------------------------------*/
+;*    example ...                                                      */
+;*---------------------------------------------------------------------*/
+(define-markup (example #!rest opts #!key legend class)
+   (new container
+      (markup 'example)
+      (ident (symbol->string (gensym 'example)))
+      (class class)
+      (required-options '(:legend :number))
+      (options `((:number
+		  ,(new unresolved
+		      (proc (lambda (n e env)
+			       (resolve-counter n env 'example #t)))))
+		 ,@(the-options opts :ident :class)))
+      (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;*    example-produce ...                                              */
+;*---------------------------------------------------------------------*/
+(define-markup (example-produce example . produce)
+   (list (it "Example:")
+	 example
+	 (if (pair? produce)
+	     (list (paragraph "Produces:") (car produce)))))
+
+;*---------------------------------------------------------------------*/
+;*    markup-ref ...                                                   */
+;*---------------------------------------------------------------------*/
+(define-markup (markup-ref mk)
+   (ref :mark mk :text (code mk)))
+
+;*---------------------------------------------------------------------*/
+;*    &the-index ...                                                   */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index
+   :class 'markup-index
+   :options '(:column)
+   :before (lambda (n e)
+	      (output (markup-option n 'header) e))
+   :action (lambda (n e)
+	      (define (make-mark-entry n fst)
+		 (let ((l (tr :class 'index-mark-entry
+			     (td :colspan 2 :align 'left 
+				(bold (it (sf n)))))))
+		    (if fst
+			(list l)
+			(list (tr (td :colspan 2)) l))))
+	      (define (make-primary-entry n p)
+		 (let* ((note (markup-option n :note))
+			(b (markup-body n)))
+		    (when p 
+		       (markup-option-add! b :text 
+					   (list (markup-option b :text) 
+						 ", p."))
+		       (markup-option-add! b :page #t))
+		    (tr :class 'index-primary-entry
+		       (td :colspan 2 :valign 'top :align 'left b))))
+	      (define (make-column ie p)
+		 (let loop ((ie ie)
+			    (f #t))
+		    (cond
+		       ((null? ie)
+			'())
+		       ((not (pair? (car ie)))
+			(append (make-mark-entry (car ie) f) 
+				(loop (cdr ie) #f)))
+		       (else
+			(cons (make-primary-entry (caar ie) p)
+			      (loop (cdr ie) #f))))))
+	      (define (make-sub-tables ie nc p)
+		 (define (split-list l num)
+		    (let loop ((l l)
+			       (i 0)
+			       (acc '())
+			       (res '()))
+		       (cond
+			  ((null? l)
+			   (reverse! (cons (reverse! acc) res)))
+			  ((= i num)
+			   (loop l
+				 0
+				 '()
+				 (cons (reverse! acc) res)))
+			  (else
+			   (loop (cdr l)
+				 (+ i 1)
+				 (cons (car l) acc)
+				 res)))))
+		 (let* ((l (length ie))
+			(w (/ 100. nc))
+			(iepc (let ((d (/ l nc)))
+				 (if (integer? d) 
+				     (inexact->exact d)
+				     (+ 1 (inexact->exact (truncate d))))))
+			(split (split-list ie iepc)))
+		    (tr (map (lambda (ies)
+				(td :valign 'top :width w
+				   (if (pair? ies)
+				       (table :width 100. (make-column ies p))
+				       "")))
+			     split))))
+	      (let* ((ie (markup-body n))
+		     (nc (markup-option n :column))
+		     (pref (eq? (engine-custom e 'index-page-ref) #t))
+		     (loc (ast-loc n))
+		     (t (cond
+			   ((null? ie)
+			    "")
+			   ((or (not (integer? nc)) (= nc 1))
+			    (table :width 100. :&skribe-eval-location loc
+			       (make-column ie pref)))
+			   (else
+			    (table :width 100. :&skribe-eval-location loc
+			       (make-sub-tables ie nc pref))))))
+		 (output (skribe-eval t e) e))))
+
+;*---------------------------------------------------------------------*/
+;*    compiler-command ...                                             */
+;*---------------------------------------------------------------------*/
+(define-markup (compiler-command bin . opts)
+   (disp :verb #t 
+	 (color :fg "red" (bold bin))
+	 (map (lambda (o)
+		 (list " [" (it o) "]"))
+	      opts)
+	 "..."))
+
+;*---------------------------------------------------------------------*/
+;*    compiler-options ...                                             */
+;*---------------------------------------------------------------------*/
+(define-markup (compiler-options bin)
+   (skribe-message "  [executing: ~a --options]\n" bin)
+   (let ((port (open-input-file (format "| ~a --options" bin))))
+      (let ((opts (read port)))
+	 (close-input-port port)
+	 (apply description (map (lambda (opt) (item :key (bold (car opt))
+						     (cadr opt) "."))
+				 opts)))))