Master Foo's Institute of Technology

Programming - Lithp

(LISP)

If you bothered to read the programming timeline, you should know that lisp is a whole lot different from all the other languages we've been studying. No fear, though: it's also very cool, once you get the hang of it. And if you've been through the other programming tutorials already, this should be easy.

Getting lisp

If you know anything about linux, you know there are a bajillion distros out there. It's the same thing with lisp, as there are a bunch of different lisps out there. For windows, you can either grab clisp, lispworks, or Allegro cl, the last two of which are commercial. There are more implementations out there that support Windows, but those are the big players. If you want clisp or the free version of acl packaged nicely, you can try Lispbox. Just execute the shell script, and you'll have emacs with slime up and running!

Where did lispbox come from?

So I must admit, this tutorial is nowhere a complete survey of the language, and I lispbox comes from a much better tutorial on lisp. Actually, it's a book, and Practical Common Lisp is a very good introduction to the language. If you're serious about learning lisp, I suggest continuing your lisp education with Peter's book.

Hacking lisp

So, with the assertation lisp is a dynamic, strongly typed language, let's jump right on in:

p>(+ 1 2)

What?

No, seriously. It puts the + in front and wraps everything in parentheses1. Let's do some more math:

p>(+ (* 13 4) (pow 2 4) (/ (+ 10 23) (- 13 45)))

The traditional infix notation would be:

p>13 * 4 + 2^4 + (10 + 23) / (13 - 45)

It definitely saves you from having to remember your precedence rules. Aside from that, though, it also saves typing on long lists:

p>(+ 1 2 3 4 5 6)

versus

p>1 + 2 + 3 + 4 + 5 + 6

Enough math! Enough math! Let's look at something a little more complex:

(defvar x 10)

A variable definition! If you haven't figured out how s-expressions work yet, look at this:

p>(operator arguments...)

and everything in lisp is written as such. Thus, the opreator for this s-exprs is defvar, which takes a variable name (a symbol) and a value (10). Before we plunge into the ttool (the lisp program I wrote to create this site) I have to tell you about one more thing:

p>(map 'list #'(lambda (x) (+ x 2)) '(1 2 3 4 5))

Huh? The map operator is a sort of loop. Given a function with #'function, map loops over all the list given by '(1 2 3 4 5) and returns another 'list, specifically '(3 4 5 6 7). Huh? First, the '(...) notation essentially makes a list. 1 is not an operator, and I hope it will never be. Instead, '(1 2 3 4 5) is just a list of 1, 2, 3, 4, and 5 as numbers. The 'list is a symbol. If it were just list, then it would be evaluated as a variable, but as 'list, it's only a symbol; equal to any other 'list but not equal to anything else, even the value of the variable list (there isn't one, in case you're wondering). (lambda (...) ...) then, is an annonymous function. That way, you don't have to define a new function everytime you want to map over a list.

ttool

Hopefully, you aren't too confused, because I'm going to unload all ~300 lines of ttool on you:

p>;--------ttool

(defpackage :ttool
(:use :cl-user)
(:shadow :block))


(in-package :ttool)

(defun main ()
(if ext:*args*
(let ((path (pathname (car ext:*args*))))
(progn
(output-html (make-html (parse (get-file path)))
(convertpath-htmlfile path)
(find-template path))
(die-and-exit "success!")))
(die-and-exit "argument not given")))

;--------------------------------------------------------------------------------

(defun parse (str)
"return list (... (...) (... (...)))"
(let ((contents (split str #\Newline))
(res nil))
(loop for line in contents
for node = line
then (cond
((null node)
line)
((or (equal line "")
(reduce (fn (x y) (and x y))
(map 'list #'whitespace line)))
(progn
(appendend res (tabs (if (consp node) (car node) node)) (if (consp node)
node
(list node)))
nil))
((stringp node)
(if (< (tabs node) (tabs line))
(list node (list line))
(list (cat node (vector #\Newline) line))))
(t
(if (null (cdr node))
(list (cat (car node) line))
(list (car node) (list (cat (car (second node)) line))))))
finally (appendend res (tabs (if (consp node) (car node) node))
(if (stringp node)
(list node)
node)))
res))

(defun get-file (file)
"gets and returns file in single array"
(with-open-file (f file)
(read-seq f)))

(defun make-html (lst)
"makes html from (...(...) ...) according to , return list ' head, body, tail ' is passed to by parse"
(let ((lr (car (replacepipe (parl (cdr lst) 1))))
(titl (subseq (car (car lst)) 0 (position #\Newline (car (car lst)))))
(stit (subseq (car (car lst)) (position #\Newline (car (car lst))))))
(list titl
(cat (tag "h1" titl) (vector #\Newline)
(tag "h3" stit) (vector #\Newline)
(first lr))
(second lr))))

(defparameter *headings* '("h1" "h2" "h3" "h4" "h5" "h6"))

(defun parl (lst dpth)
(flet ((parl-r (x) (parl x dpth)))
(cond
((and (stringp (car lst)) (null (cdr lst)))
(cat (vector #\Newline)
(tag "p" (trimtabs (car lst)))
(vector #\Newline)))
((consp (car lst))
(reduce #'cat (map 'list #'parl-r lst)))
((equal "note" (subseq (trimtabs (car lst)) 0 (position t (trimtabs (car lst)) :key #'whitespace)))
(let ((nt (note))
(cont (parl-r (cdr lst))))
(cat (tag "div" (cat (tag "h3" (subseq (car lst) 6))
(tag "div" cont
'("class" "innote")
(list "id" (cat "note" nt))))
(list "onClick" (cat "expnote('note" nt "');"))
(list "class" "note"))
(vector #\Newline))))
((equal "code" (subseq (trimtabs (car lst)) 0 (position t (trimtabs (car lst)) :key #'whitespace)))
(let ((cont (reduce #'cat (map 'list #'parl-r (cdr lst)))))
(cat (tag "div" (tag "pre" (subseq cont dpth))
(list "class" "code"))
(vector #\Newline))))
((equal "list" (subseq (trimtabs (car lst)) 0 (position t (trimtabs (car lst)) :key #'whitespace)))
(let ((cont (reduce #'cat (map 'list (fn (x) (cat (tag "li" (trimtabs (car x)))
(vector #\Newline)))
(cdr lst)))))
(cat (tag "ul" cont) (vector #\Newline))))
(t (let ((cont (reduce #'cat (map 'list #'parl-r (cdr lst)))))
(cat (tag (elt *headings* dpth) (car lst))
(vector #\Newline)
cont))))))

(defun int->char (w)
(let ((arr (make-array 1 :adjustable t :fill-pointer 0 :element-type 'character)))
(do ((c w (floor (/ c 10)))
(p (code-char (+ 48 (floor (* 10 (- (/ w 10) (floor (/ w 10)))))))
(code-char (+ 48 (floor (* 10 (- (/ c 100) (floor (/ c 100)))))))))
((> 1 c) (reverse arr))
(vector-push-extend p arr))))

(let ((n 0) (f 0))
(defun footnote () (int->char (incf f)))
(defun note () (int->char (incf n)))
(defun newpage () (progn (setf f 0) (setf n 0))))

(defun replacepipe (str)
"finds and replaces , link:, ftnote, code, def:"
(let ((lr (split str #\)))
(repl lr)))

(defun repl (lst)
(flet ((wrapd (str)
(let ((op (subseq str 0 (position #\Space str))))
(cond
((equalp op "link")
(list (tag "a" (subseq str 4 (position #\: str))
(list "href"
(subseq str (+ 1 (position #\: str)))))
""))
((equalp op "code")
(list (tag "div" (tag "pre" (subseq str 4))
(list "class" "code"))
""))
((equalp op "def")
(list (tag "acronym" (subseq str 3 (position #\: str))
(list "title" (subseq str (+ 1 (position #\: str)))))
""))
((equalp op "ftnote")
(let ((ftn (footnote)))
(list
(tag "span" (tag "a" ftn (list "href" (cat "#ftnote" ftn)))
'("class" "toftnote"))
(tag "div" (cat (tag "a" ftn (list "name" (cat "ftnote" ftn)))
(subseq str 6))
'("class" "ftnote")))))
(t nil))))
(wrap? (str)
(let ((op (subseq str 0 (position #\Space str))))
(if (or (equal op "link") (equal op "code") (equal op "def") (equal op "ftnote"))
t))))
(if (null lst) ;----------------doing it recursively doesn't work out well
'(("" ""))
(if (wrap? (first lst))
(if (wrap? (second lst))
(let* ((lr (repl (cdr lst)))
(cr (wrapd (cat (first lst) (first (first lr)) (first (second lr)))))
(l2 (repl (cdr (second lr)))))
(list (list (cat (first cr)
(first (first l2)))
(cat (second (first lr))
(second cr)
(second (first l2))))))
(if (wrap? (third lst))
(let ((cr (wrapd (cat (first lst))))
(lr (repl (cddr lst))))
(list (list (cat (first cr) (second lst) (first (first lr)))
(cat (second cr) (second (first lr))))
(second lr)))
(list (wrapd (first lst))
(cdr lst))))
(if (wrap? (second lst))
(let* ((lr (repl (cdr lst)))
(lr2 (repl (second lr))))
(list (list (cat (first lst)
(first (first lr))
(first (first lr2)))
(cat (second (first lr)) (second (first lr2))))))
(let ((lr (repl (cdr lst))))
(list (list (cat (first lst) (first (first lr)))
(second (first lr))))))))))

(defun output-html (parts out-path temp-path)
"taking template and the html, print to the path"
(let ((hd (car parts)) (bd (second parts)) (tl (third parts)))
(with-open-file (f out-path :direction :output)
(write-seq
(multiple-value-bind (head bodystart bodyend end)
(parse-template temp-path)
(cat head hd bodystart bd bodyend tl end))
f))))

(defun convertpath-htmlfile (path)
"return the path to the html instead of other type"
(make-pathname :defaults path :type "html"))

(defun find-template (path)
"find the template given the path, in higher directory"
(let ((p (make-pathname :defaults path :name "temp" :type "html")))
(cond
((probe-file p)
p)
((probe-file (merge-pathnames (pathname "../") p))
(merge-pathnames (pathname "../") p))
(t (die-and-exit "no template file")))))
(defun parse-template (path)
(with-open-file (f path)
(flet ((poundfind (str c) (position #\# str :start c)))
(let* ((file (read-seq f))
(pounds (loop for c = (poundfind file 0) then (poundfind file (+ c 1))
until (null c)
collect c)))
(values (subseq file 0 (elt pounds 0))
(subseq file (+ 1 (elt pounds 0)) (elt pounds 1))
(subseq file (+ 1 (elt pounds 1)) (elt pounds 2))
(subseq file (+ 1 (elt pounds 2))))))))
(defun die-and-exit (str)
(progn
(format t str)
(ext:exit)))

(defun cat (&rest strings)
"concatenate"
(let ((res ""))
(loop for str in strings
do (setf res (concatenate 'string res (subseq str 0 (position #\Null str)))))
res))

(defun whitespace (x) (case x (#\ t) (#\Newline t) (#\Tab t) (t nil)))

(defmacro appendend (x lvl obj)
`(if ,x
(setf (cdr (last (do ((c 0 (+ c 1))
(lst ,x (car (last lst))))
((= c ,(if (null lvl)
0
lvl)) lst))))
(list ,obj))
(setf ,x (list ,obj))))

(defun tabs (x) (if (equal x "")
0
(loop for c from 0
for m across x
when (not (equal m #\Tab))
return c)))

(defun tag (name bd &rest rst)
(cat "<" name (if rst " "
(if bd ">" "/>"))
(if rst (reduce #'(lambda (x y) (cat x " " y))
(loop for (nm val) in rst
collect (cat nm "=" "\"" val "\""))))
(if rst (if bd ">" "\>") "")
bd
(if bd (cat ""))))

(defmacro fn (args &body body)
`(function (lambda ,args ,@body)))

(defun split (str dlm)
(loop for pp = 0
then (+ p 1)
for p = (position dlm str)
then (position dlm str :start (+ 1 p))
for n = (list (subseq str 0 p))
then (append n (list (subseq str pp p)))
when (null p)
return n))

(defun trimtabs (str)
(let ((tp (position t str :key (fn (x) (if (not (equal #\Tab x)) t)))))
(subseq str (if tp tp 0))))
(defun and-rest (&rest r)
"because and isn't good enough"
(do ((l r (cdr l))
(x (first r) (first l))
(res t (and x res)))
((null l) (and x res))))

(defun read-seq (stream)
"because read-sequence broke on me"
(let ((str (do ((char (read-char stream nil) (read-char stream nil))
(str (make-array 1 :adjustable t :element-type 'character :fill-pointer 0)))
((null char) str)
(vector-push-extend char str))))
(if (reduce #'and-rest (map 'list #'whitespace (subseq str (position #\Newline str :from-end t))))
(subseq str 0 (position #\Newline str :from-end t))
str)))

(defun write-seq (seq stream)
"because write-sequence seems to be acting up, too"
(loop for char across seq
do (write-char char stream)))

WOW!! BACK UP!!!!

Nope! No going back! So, if you want to be able to run this, you need to startup your implementation of lisp (not necessarily lispbox) and type the following (under clisp. If you're using acl, well, good luck.):

p>(load "where you downloaded the file below") 


(saveinitmem "choose a path" :)

Here are a couple ttool sources to work on.


1 It's an s-expression