#! /usr/bin/env clisp ;;; * Copyright (c) 2013, Philippe Brochard ;;; * All rights reserved. ;;; * Redistribution and use in source and binary forms, with or without ;;; * modification, are permitted provided that the following conditions are met: ;;; * ;;; * * Redistributions of source code must retain the above copyright ;;; * notice, this list of conditions and the following disclaimer. ;;; * * Redistributions in binary form must reproduce the above copyright ;;; * notice, this list of conditions and the following disclaimer in the ;;; * documentation and/or other materials provided with the distribution. ;;; * * Neither the name of the University of California, Berkeley nor the ;;; * names of its contributors may be used to endorse or promote products ;;; * derived from this software without specific prior written permission. ;;; * ;;; * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY ;;; * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;;; * DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY ;;; * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;;; * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ;;; * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ;;; * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defparameter sep #\.) (defparameter comment-char #\% "Comment char on line beginning") (defparameter trim (format nil "< >~A" sep)) (defparameter current-id 0) (defparameter current-h1 0) (defparameter current-h2 0) (defparameter total-tag 0) (defparameter h1-list nil) (defparameter h2-list nil) (defparameter current-hide 0) (defun split-string (string &optional (separator #\Space)) "Return a list from a string splited at each separators" (loop for i = 0 then (1+ j) as j = (position separator string :start i) as sub = (subseq string i j) unless (string= sub "") collect sub while j)) (defun analyse-tag (tag) (when (position sep tag) (mapcar (lambda (x) (string-trim trim x)) (split-string (string-trim trim tag) sep)))) (defmacro deftag (tag (&rest param) &body body) (let ((symb (intern (string-upcase (format nil "process-~A-tag" tag))))) `(defun ,symb ,param ,@body))) (defun substitute-tag (tag) (let ((atag (analyse-tag tag))) (if atag (let ((fun (intern (string-upcase (format nil "process-~A-tag" (first atag)))))) (handler-case (apply fun (rest atag)) (error (c) (when (fboundp fun) (format t "Error in '~A': ~A~%" tag c)) tag))) tag))) (defun change-tag (string &optional (ret "")) (let ((pos (position #\< string))) (if pos (let ((posend (position #\> string))) (concatenate 'string ret (subseq string 0 pos)) (if posend (change-tag (subseq string (1+ posend)) (concatenate 'string ret (subseq string 0 pos) (substitute-tag (subseq string pos (1+ posend))))) (concatenate 'string ret string))) (concatenate 'string ret string)))) (defun write-header (output title) (format output " ~A
Aide   Cours   Construction

" title)) (defun write-footer (output) (format output "

" (reverse h1-list) (1+ (first h1-list)) (reverse h2-list) (first h1-list) current-hide)) (defun make-onclick () (format nil "id='id~A' onclick=\"document.getElementById('butt_next').focus();\"" (incf current-id))) (deftag titre () (incf total-tag) (format nil "

" (1+ current-id))) (deftag /titre () "

") (deftag h1 () (setf current-h2 0) (push current-id h1-list) (incf total-tag) (format nil "") (deftag h2 () (incf total-tag) (push current-id h2-list) (format nil "") (deftag p () (incf total-tag) (format nil "") (defmacro deftag-simple (tag) `(progn (deftag ,tag (&rest args) (incf total-tag) (format nil "<~A class='hidden' ~A ~{~A ~}>" ',tag (make-onclick) args)) (deftag ,(intern (string-upcase (format nil "/~A" tag))) () (format nil "" ',tag)))) (deftag-simple span) (deftag-simple ul) (deftag-simple li) (deftag-simple th) (deftag-simple td) (deftag-simple tr) (deftag hide () (let ((id (incf current-hide))) (format nil "" id id))) (deftag /hide () "") (deftag plop (a b) (format nil "[b=~A a=~A]" b a)) (deftag /plop () "[fin plop]") (deftag rouge () "") (deftag /rouge () "") (deftag r () "") (deftag /r () "") (deftag rb () "") (deftag /rb () "") (deftag vert () "") (deftag /vert () "") (deftag v () "") (deftag /v () "") (deftag vb () "") (deftag /vb () "") (deftag bleu () "") (deftag /bleu () "") (deftag b () "") (deftag /b () "") (deftag bb () "") (deftag /bb () "") (deftag color (color) (format nil "" color)) (deftag /color () "") (deftag br (n-lines) (with-output-to-string (str) (dotimes (n (parse-integer n-lines :junk-allowed t)) (format str "
")) (format str "~%"))) (defun change-ext (filename newext) (let ((pos (position #\. filename :from-end t))) (if pos (concatenate 'string (subseq filename 0 pos) "." newext) filename))) (defun main (filename) (let ((output-filename (change-ext filename "html"))) (format t "Construction de '~A' vers '~A'~%" filename output-filename) (let ((nline 0)) (with-open-file (stream filename :direction :input) (with-open-file (output output-filename :direction :output :if-exists :supersede) (write-header output output-filename) (loop for line = (read-line stream nil nil) while line do (incf nline) (unless (and (plusp (length line)) (eql (char line 0) comment-char)) (format output "~A~%" (change-tag line)))) (push total-tag h1-list) (write-footer output))) (format t " Lignes lues : ~A. Sections H1 : ~{~A~^, ~}. Sections H2 : ~{~A~^, ~}. Mots cachés : ~A~%" nline (reverse h1-list) (reverse h2-list) current-hide)))) (main (first ext:*args*))