Posts tagged Lisp

I was getting a lot of “Connection reset by peer” errors on my website, originally I thought it was Hunchentoot or couchDB but it turned out that c-couch was the problem.

To get things working comment out the :content parameter from the call to drakma:http-request inside (defun http-request … )

I’m not sure what those lines do or how they are broken but commenting them out solved the problem for me.

EDIT: The answer is those lines let you update data… whoops. Anyway I figured it out, here’s a patch that fixes the problem properly.

Cheers, Dave.

I have been reading up on CouchDB, an interesting alternative to using relational databases for (usually) completely the wrong purpose. After the last contract I have been working on and having to deal with the mess that led to I can really see the need for tools like this.

I always thought it was weird how you ended up having to do loads of queries per page viewed, how you are limited by SQL when doing anything more complex things and buggered when it came to storing tree’s or other structures. With CouchDB queries are prepared in advance using proper programing languages and are called views, this lets you grab stuff with a lot more power. Also interesting was the idea that you are not forced into a rigid structure for your data. (You can have a query that simple ignores records that aren’t relevant for example.)

A free online book, friendly IRC channel and a great Lisp library are some of the bonuses to what already looks like a pretty good idea.

Another really interesting part of CouchDB is that it gives you your data in JSON form so you can actually skip the ‘PHP Layer’ and make a dynamic application with just HTML, Javascript and CouchDB! (Just view the source of that page to see!)

I am going to write a couple of basic programs to get the hang of CouchDB soon but before I started I needed to get a few examples working. It took me a while so to save you the bother here is the code:

(asdf:oos 'asdf:load-op :cl-couch)

; Setup the blog package
(defpackage :blog
  (:use :asdf :asdf-install :cl :hunchentoot :cl-who :cl-couchdb-client)
  (:shadowing-import-from #:cl-couchdb-client #:url-encode :url-decode))
(in-package :blog)

; Connect to CouchDB
(open-server)

; Create a database
(couch-request :put (contacts))

; Add a few records
(couch-request :post (contacts) '(("Name" . "Simon") 
                                  ("Skype" . "simon@skype.com")))

(couch-request :post (contacts) '(("Name" . "Hozay Jones") 
                                  ("Email" . "hozay@gmail.com")
                                  ("Address" . "123 test st")))

(couch-request :post (contacts) '(("Name" . "Dave") ("Website" . "http://kzar.co.uk")))

(couch-request :post (contacts) '(("Crap" . "Blah")))

; List the records
(couch-request :get (contacts _all_docs))

; Now using futon create a view for the contacts database
; Here is the map javascript function to use:

;function(doc) {
;  if (doc.Name) {
;    emit(doc.Name, doc);
;  }
;}

; Call the design document contacts and the view by_name

; Now we can use this view to see all the records with a Name
(couch-request :get (contacts/_view/contacts/by_name))

; And now any with the name Simon
(couch-request :get (contacts/_view/contacts/by_name :key "\"Simon\""))

(I am brand new to this so I might have done some bits in a stupid way, it does give you somewhere to start from though.)

Any feedback would be great,

Cheers, Dave.

Someone in #lisp asked about permutations the other day, I hadn’t come across them before so after looking up what they where I decided it sounded like a good programming exercise to try and find all the permutations for a given string.

Anyway it took me a little while to figure out how to do it but once I did it wasn’t so hard, here’s the code:

(defun transpose (string position)
  "Return string with the characters at position transposed"
  (let ((before (when (> position 0) 
                  (subseq string 0 position)))
        (after (when (< (+ 1 position) (length string))
                 (subseq string (+ 2 position)))))
    (concatenate 'string before 
                 (subseq string (+ position 1) (+ position 2))
                 (subseq string position (+ position 1))
                 after)))

(defun permutations-helper (permutations position)
  "Does the hard work for the permutations function."
  (cond ((not permutations) nil)
        ((eql (length (car permutations)) (+ position 1)) permutations)
        (t (permutations-helper 
            (append permutations (mapcar (lambda (x) (transpose x position)) permutations))
            (+ 1 position)))))

(defun permutations (string)
  "Take a string and return a list of it's permutations"
  (remove-duplicates (permutations-helper (list string) 0) :test #'equal))

(permutations "population")

Any feedback would be great, feel free to use the code.

Cheers, Dave.

---

Edit: Before I re-wrote my blog there was a great comment from Kelsar that corrected the above code. I've included it below so anyone reading this has a working example to peek at and to help show how the above example is broken.

There is something wrong in your program; for example: (member “trebor” (permutations “robert”)) -> NIL

You probably need something like “rotation” of string. This is my version (on lists, not strings, but this is the same):

;utility function
(defun mappend (fn lst)
(apply #’append (mapcar fn lst)))

;rotation
(defun rot (lst) `(,@(cdr lst) ,(car lst)))

(defun full-rot (lst)
(let ((bf (list lst)))
(do ((x (rot lst) (rot x))) ((equal x lst))
(push x bf)) bf))

;;permutations
(defun permutation (lst)
(if (null lst) ‘(())
(mappend #’(lambda (x) (full-rot (cons (car lst) x))) (permutation (cdr lst)))))

(permutation ‘(1 2 3 4))

greetings, kelsar

A while ago I posted about my horrible scraper code and about how I was too embarrassed to share it…

Well it actually worked really well, it emailed me nice “HTML diff’s” of how the page was changing every now and then and it did it’s little job quite well.

I have decided to post it so that if someone wants to write a scraper / emailer in Lisp at least they have an example. (I couldn’t find many examples of how to use a lot of these libraries to start with which made it quite hard.)

So excuse the mess, here’s the code:

(asdf:operate 'asdf:compile-op :curl)
(asdf:operate 'asdf:load-op :curl)
(require :cl-html-parse)
(require :htmlgen)
(require :cl-html-diff)
(require :cl-smtp)

;; TODO
; Fix logic so that it doesn't go crazy when the page / selection is empty
; Get rid of those horrible changed, same and new functions
; Get rid of email list at the top
; Tidy up the send mail function

;; Settings
(defparameter *mailserver* "localhost")

(defparameter *emails* '("kzar@kzar.co.uk" "fredbob@gmail.com"))

(defparameter *store* "/home/kzar/scrape/"
  "Where all the temp files are saved.")

(defparameter *log-file* "/var/log/visa-check.log")

;; Workings
(defvar *branches-above*)

(defun parse-html (html)
  "Take some HTML and return a tree."
  (NET.HTML.PARSER:parse-html html))

(defun craft-html (tree)
  "Take a tree and return some HTML"
  (with-output-to-string (stream)
    (net.html.generator:html-print tree stream)))

(defun load-file (filename)
  "Load the file given by filename and and return the contents as a string"
  (with-open-file (in filename)
    (with-standard-io-syntax
      (let ((seq (make-string (file-length in))))
        (read-sequence seq in)
        seq))))

(defun load-html (filename)
  "Load a HTML file and parse it into s-expresions"
  (parse-html (load-file filename)))

(defun save-string (filename string)
  "Write the string to filename (overwriting anything that might already be there)."
  (with-open-file (out filename
                       :direction :output
                       :if-exists :supersede)
    (with-standard-io-syntax
      (write-string string out))))

(defun save-html (filename html)
  "Save some s-expressions to HTML"
  (save-string filename (craft-html html)))

(defun append-string (filename string)
  "Append the string to the end of the file given by filename"
  (with-open-file (out filename
                       :direction :output
                       :if-exists :append)
    (with-standard-io-syntax
      (write-string string out))))

(defun time-stamp ()
  "Return a nicely formatted timestamp of the current date / time"
  (multiple-value-bind (second minute hour day month year)
      (decode-universal-time (get-universal-time))
    (format nil "~A/~A/~A ~A:~A:~A" day month year hour minute second)))

(defun log-message (message)
  "Append a log entry to the *log* file, including a timestamp"
  (append-string *log-file* (concatenate 'string (time-stamp) ": " message)))

(defun file-exists? (filename)
  "Return T if the filename exists, nil otherwise"
  (if (with-open-file (in filename :if-does-not-exist nil)
        in)
      t))

(defun download (URL)
  "Download the contents of the URL and return it"
  (curl:with-connection-returning-string (:cookies nil)
    (curl:set-option :url URL)
    (curl:perform)))

(defun strip-utf (string)
  "Return string minus any UTF characters."
  (remove-if (lambda (x) (> (char-code x) 127))
             string))

(defun send-email (from to subject body)
  "Use cl-smtp to send an email."
  (cl-smtp:send-email
   *mailserver*
   from
   to
   subject
   (format nil "<style type=\"text/css\">ins {background: #bfb} del{background: #fcc} ins,del {text-decoration: none}</style>~A" body)
   :extra-headers '(("Content-type" "text/html; charset=\"iso-8859-1\""))))

(defun spam (from subject body)
  "Spam everyone in *emails* the email given by the parameters"
  (dolist (email *emails*)
    (send-email from email subject body)))

(defun list-if (foo)
  "If foo's not nil return (list foo)."
  (if foo
      (list foo)))

(defun find-item (item list &key strict?)
  "Return item if item is inside the list, nil otherwise. If strict? is nil and item is a string, the list can contain a string that just contains the item."
  (if (or strict?
          (not (stringp item)))
      (find item list :test 'equal)
      (if (loop for hay in list
             if (stringp hay) 
             if (search item hay) collect it
             else if (equal item hay) collect it)
          item)))

(defun find-all (symbols list &key strict?)
  "Take a list of symbols and do a find for each in the list. If strict? is nil then also grep strings for a match.."
  (if (not (consp symbols))
      (list-if (find-item symbols list :strict? strict?))
      (if (equal symbols
                 (loop for symbol in symbols
                    collect (find-item symbol list :strict? strict?)))
          symbols
          nil)))

(defun find-tag-helper (tag tree elements strict? branches-above)
  "Does the work for find-tag, horrible horrible mess! *Hangs head in shame*"
  (if (and (eql (car tree) tag)
           (or (not elements)
               (find-all elements tree :strict? strict?)))
      (progn
        (setf *branches-above* branches-above)
        tree)
      (let ((goal (or (if (consp (car tree))
                          (find-tag-helper tag (car tree) elements strict? branches-above))
                      (if (consp (cdr tree))
                          (find-tag-helper tag (cdr tree) elements strict? branches-above)))))
        (if (and (numberp *branches-above*)
                 (> *branches-above* 0))
            (progn
              (decf *branches-above*)
              tree)
            goal))))

(defun find-tag (tag tree &key elements (strict? t) (branches-above 0))
  "Take a tree, a tag and the tag's value and return the rest of the tree from that point."
  (let ((*branches-above* 0))
    (find-tag-helper tag tree elements strict? branches-above)))

(defmacro add-page (page-list url name &body body)
  `(push (list ,url ,name 
               (lambda (html) ,@body)) ,page-list))

(defun check-page (URL name func)
  "Take a URL, download the page and have a look for differences"
  (let* ((filename (concatenate 'string *store* name "/old"))
         (new-file (funcall func (parse-html (download URL)))))
    (ensure-directories-exist filename)
    (if (file-exists? filename)
        (let ((old-file (car (load-html filename)))) ;; FIXME why is this (car needed?!
          (if (equal old-file new-file)
              (same-page name new-file)
              (changed-page name 
                            (save-html filename new-file)
                            (html-diff:HTML-DIFF (craft-html old-file) (craft-html new-file)))))
        (new-page name (save-html filename new-file)))))

(defun new-page (title html)
  "Function that's called when a page is checked for the first time"
  (log-message (format nil "NEW Page - ~A~%" title))
  (spam "kzar@kzar.co.uk" 
        (format nil "**Visa Alert** - New Page (~A)" title)
        (format nil "I have started watching this new page called \"~A\". ~%~%Here's the HTML:~%~%~A"  title html)))

(defun same-page (title html)
  "Called when the page is the same, (possibly does nothing!)"
  (log-message (format nil "no change to - ~A~%" title)))

(defun changed-page (title html diff)
  "Function that's called when a page changed. Email everyone and sound the sirens!"
  (log-message (format nil "CHANGED PAGE - ~A~%" title))
  (spam "kzar@kzar.co.uk"
        (format nil "**Visa Alert** - Changed Page (~A)" title)
        (format nil "The page ~A has changed! Below is a diff: ~%~%~A" title diff)))

(defun check-pages (pages)
  "Check all the pages given by for changes."
   (dolist (page pages)
     (check-page (car page) (cadr page) (caddr page))))

(let (pages)
  (add-page pages "http://www.bunac.org/UK/workcanada/applying.aspx" "Visa application Page"
    (find-tag :style html :elements '("#FF924A") :strict? nil :branches-above 2))

  (add-page pages "http://kzar.co.uk/testpage" "Test Page"
    (car html)) ; FIXME WHY IS THIS CAR REQUIRED?!

  (add-page pages "http://www.bunac.org/uk/workcanada/" "Visa Homepage"
    (find-tag :div html :elements '("width:480px") :strict? nil :branches-above 1))

  (add-page pages "https://www.bunac.org/applyCanada/" "Visa payment page"
    (find-tag :div html :elements "bodyContent" :strict? nil :branches-above 1))
  
  (check-pages pages))

(quit)

(So please bare in mind that the code is very thrown together, if you are using it for something important make sure it works properly first.)

I had it running every hour by putting a shell script in my /etc/cron.hourly to run the code in a new SBCL:

#!/bin/bash
/usr/src/clbuild/clbuild preloaded --load /var/lisp/visa-check.cl

(That’s why there’s a (quit) at the end of the lisp code, it makes sure that the new SBCL is closed again, otherwise it would open an extra one every hour.)

Anyway it’s quite nice, it emails you notification of changes like this:

Cheers, Dave

After being inspired by this amazing genetic algorithm demo I decided to get learning.

For my first attempt at anything like this I found a great guide [1] and programmed the example. The algorithm had the task of making an equation that equaled a goal number. So for example I might tell it “Make me an equation 9 long that creates 13″ and it could come back with (1 * 9 + 2 + 6 - 4).

It took quite a while to get it working because there’s lots of randomness involved and mistakes anywhere stop the whole algorithm working, turning the result seemingly completely random. It all works well now though and I’m quite pleased with the code, it’s clean and I manged to optimise it to run a lot faster.

(defvar *genes* '((0 (0 0 0 0))
                  (1 (0 0 0 1))
                  (2 (0 0 1 0))
                  (3 (0 0 1 1))
                  (4 (0 1 0 0))
                  (5 (0 1 0 1))
                  (6 (0 1 1 0))
                  (7 (0 1 1 1))
                  (8 (1 0 0 0))
                  (9 (1 0 0 1))
                  (+ (1 0 1 0))
                  (- (1 0 1 1))
                  (* (1 1 1 1))
                  (/ (1 1 0 1))))

(defvar *mutation-rate* 0.001)
(defvar *crossover-rate* 0.7)

(defun random-item (list)
  "Take a list and return one item from it at random"
  (nth (random (length list)) list))

(defun generate-random-chromosome (size)
  (loop for i from 1 to size
     append (cadr (random-item *genes*))))

(defun decode-gene (gene)
  (car (rassoc gene *genes* :key #'car :test #'equal)))

(defun decode-chromosome (chromosome)
  (remove nil (loop for (a b c d) on chromosome by #'cddddr
                collect (decode-gene (list a b c d)))))

; FIXME x / 0 is silently dropped and operator precidence isn't correct
(defun find-answer (dc)
  "Find the answer given by a decoded-chromosome"
  (cond ((not (consp dc)) dc)
        ((< (list-length dc) 3) (car (remove-if-not 'numberp dc)))
        ((not (numberp (car dc))) (find-answer (cdr dc)))
        ((numberp (cadr dc)) (find-answer (cons (car dc) (cddr dc))))
        ((not (numberp (caddr dc)))
         (find-answer (append (subseq dc 0 2) (cdddr dc))))
        ((and (eql '/ (cadr dc))
              (eql 0 (caddr dc)))
         (find-answer (cons (car dc) (cddr dc))))
        (t
         (let ((simplified (eval (list (cadr dc) (car dc) (caddr dc)))))
           (if (consp (cdddr dc))
               (find-answer (cons simplified (cdddr dc)))
               simplified)))))

(defun count-flaws (dc)
  "Return the number of items in a chromosome which are semanticly wrong e.g. '(* / +) would be 3"
  (let ((should-be-number t)
        (flaw-count 0))
    (loop for gene in dc
       if (not (eql (numberp gene) should-be-number))
       do (incf flaw-count)
       do (setf should-be-number (if should-be-number nil t)))
    flaw-count))

; FIXME -100 is given to all symbol chromosomes, probably a bad idea?
(defun fitness (chromosome goal)
  "Return a fitness based on the distance from the answer and the number of gramatical flaws"
  (let ((answer (find-answer (decode-chromosome chromosome))))
    (if (numberp answer)
        (let ((distance (abs (- goal answer)))
              (flaws (count-flaws (decode-chromosome chromosome))))
          (+ (if (eql distance 0) 0 (/ 1 distance))
             (if (eql flaws 0) 0 (/ 1 flaws))))
        -100)))

(defun pool-fitness (pool goal)
  (loop for chromosome in pool
     collect (fitness chromosome goal)))

(defun mutate-bit (bit)
  "Take a 1 or 0 and mutate it."
  (if (< (random 1.0) *mutation-rate*)
      (if (eql bit 0) 1 0)
      bit))

(defun mutate (chromosome)
  "Returns a possibly mutated version of chromosome"
  (loop for bit in chromosome
     collect (mutate-bit bit)))

(defun crossover (first second)
  "Returns a mix of two chromosomes (might be the same)"
  (if (< (random 1.0) *crossover-rate*)
      (let ((point (+ (random (- (length first) 1)) 1)))
        (append (subseq first 0 point) 
                (subseq second point)))
      (random-item (list first second))))

(defun make-roulette-wheel (fitness)
  (let* ((total-fitness (reduce #'+ fitness))
         (total-probability 0.0))
    (append (loop for x in fitness
               collect total-probability
               do (incf total-probability (/ x total-fitness))) '(1.0))))
            
(defun spin-the-wheel (pool roulette-wheel)
  (let ((ball (random 1.0)))
    (declare (type float ball))
    (loop for chromosome in pool
       for (position next-pos) of-type (float float) on roulette-wheel
       if (<= ball next-pos)
       do (return chromosome))))
  
(defun re-populate (pool fitness)
  (let ((roulette-wheel (make-roulette-wheel fitness)))
    (loop for i from 1 to (length pool)
       collect (mutate (crossover (spin-the-wheel pool roulette-wheel)
                                  (spin-the-wheel pool roulette-wheel))))))

(defun create-initial-pool (pool-size chromosome-size)
  (loop for i from 1 to pool-size
     collect (generate-random-chromosome chromosome-size)))

(defun find-best-chromosome (pool fitness)
  "Returns the fittest chromosome in the pool."
  (let ((best-score) (best-chromosome))
    (loop for chromosome in pool
       for score in fitness
       do (when (or (equalp score 0) (not best-score) (> score best-score))
            (setf best-score score)
            (setf best-chromosome chromosome)))
    (values best-chromosome best-score)))

(defun there-is-a-winner (pool fitness)
  "If any of the chromsomes in the pool have the answer return the first one that does."
  (let ((winner (position 0 fitness)))
    (if winner (nth winner pool))))

(defun display-turn (pool fitness turn)
  (multiple-value-bind (chromosome score) (find-best-chromosome pool fitness)
    (let ((avg-fitness (/ (reduce #'+ fitness) (+ 1 (length pool))))
          (*print-pretty* nil))
      (format t "~a - Average Fitness: ~F Best: ~w (fitness ~F)~%" turn avg-fitness (decode-chromosome chromosome) score))))
            
(defun genetic-algorithm (goal pop-size chromosome-size tries)
  (let ((pool (create-initial-pool pop-size chromosome-size))
        (fitness))
    (loop for i from 1 to tries
       do (setf fitness (pool-fitness pool goal))
       if (there-is-a-winner pool fitness) return it
       do (display-turn pool fitness i)
       do (setf pool (re-populate pool fitness))
       finally (return (find-best-chromosome pool fitness)))))

(defun skynet (&key goal pop-size chromosome-size tries mutation-rate crossover-rate)
  (let ((best (genetic-algorithm goal pop-size chromosome-size tries))
        (*print-pretty* nil)
        (*mutation-rate* mutation-rate)
        (*crossover-rate* crossover-rate))
    (format t "~w gave ~F (Aim was ~A)" (decode-chromosome best) (find-answer (decode-chromosome best)) goal)))

; Sensible parameter values according to t'internet:
;   - 0.1 to 0.001 for mutation rate
;   - 0.7 to 0.9 for crossover rate

(skynet :goal 13
        :pop-size 100
        :chromosome-size 9
        :tries 200
        :mutation-rate 0.001
        :crossover-rate 0.7)

As always feel free to use the code, any feedback would be useful. Next up I’m going to apply GA to a more interesting problem.

Cheers, Dave.

Edit: I optimised the code by using the SBCL profiler to see what was slowing things down. It turned out that the spin-the-wheel function was taking about 92% of the time with the functions it called. Firstly I examined the function and realised I could reduce the comparisons, that reduced it to about 87%. Next the guys in #lisp explained that I should declare the variables in that function as float’s so that SBCL could optimise things for me. I tried that and it was reduced to around 36%!

I found it suprising that the ‘roulette wheel spinning’ function that’s used to select which chromomsomes are used for crossover was the most computer intensive part of my code but at least now it runs a lot faster. Although I am curious to know if my findings are normal. Also if you have any idea how I could optimise more I would be grateful, here is the profiler output.

[1] - Apparently that guide is teaching very out of date methods, possibly consider a different source of information!

---

Edit: Before I replaced Wordpress there where some really good comments that where lost. I've pasted there below so you can follow their tips

Foo said

That tutorial is really quite astonishingly crappy. So what I’m going to say is obviously exaggeration but is close to the truth:

(1) NO ONE has done roulette selection in the last ten years. Tournament selection, truncation selection, etc., yes. Roulette selection? Laughable.

(2) NO ONE has done binary encodings of non-binary problems in the last ten years. You use an encoding which matches your actual problem.

(3) NO ONE does one-point crossover any more. A parameterized uniform crossover. Or at LEAST, heaven forbid, a two-point crossover.

(4) NO ONE does genetic programming (the little encoding of math the guy’s showing) in a fixed-length string. It borders on the hilariously ignorant.

Hey, it’s all fine if you’re doing this for the first time, and you go pick up a 1970 book on genetic algorithms and publish a web page on how you coded it up. But to claim that you’re doing a TUTORIAL? This guy should have been taken out behind the shed and shot.

Dominic Said

You might find this tutorial useful: http://www.obitko.com/tutorials/genetic-algorithms/index.php

Also, the “field guide to genetic programming” by Poli, Langdon and McPhee is very up-to-date, and can be downloaded for free: http://www.lulu.com/content/2167025

After the horrible mess that was the scraper script I decided to make something a bit cleaner.

It’s a nice little game that teaches you about the different months.

It works pretty well but I think the code needs some work:

(defpackage :month-game
  (:use :cl :hunchentoot :cl-who))

(in-package :month-game)

(push (create-regex-dispatcher "^/lisp/months$" 'months-page) *dispatch-table*)
(push (create-regex-dispatcher "^/months$" 'months-page) *dispatch-table*)

(defvar *months* '((1 "January")
                   (2 "February")
                   (3 "March")
                   (4 "April")
                   (5 "May")
                   (6 "June")
                   (7 "July")
                   (8 "August")
                   (9 "September")
                   (10 "October")
                   (11 "November")
                   (12 "December")))

(defun month-name (month)
  "Take a month and return it's name"
  (cadr month))

(defun month-number (month)
  "Take a month and return it's number"
  (car month))

(defun random-item (list)
  "Take a list and return one item from it at random"
  (nth (random (length list)) list))

(defmacro create-question-template (&body body)
  "Macro to make adding question templates easier"
  `(lambda () ,@body))

(defvar *question-templates* 
  (list
   (create-question-template
     "Take a month, ask them which number it is."
     (let* ((month (assoc (+ 1 (random 12)) *months*))
            (question (format nil "What is the ~:r month called?" (month-number month)))
            (correct-response (format nil "That's correct!~%"))
            (wrong-response (format nil "Wrong, the ~:r month is ~A~%" (month-number month) (month-name month)))
            (test-fun (lambda (awnser) 
                        (if (string-equal awnser
                                          (month-name month))
                            t))))
       (list question test-fun correct-response wrong-response)))

   (create-question-template
    "Give a month and take it's number."
    (let* ((month (assoc (+ 1 (random 12)) *months*))
           (question (format nil "Which number month is ~A?" (month-name month)))
           (correct-response (format nil "That's correct!~%"))
           (wrong-response (format nil "No, that's wrong.. ~A is the ~:r month.~%" (month-name month) (month-number month)))
           (test-fun (lambda (awnser) 
                       (if (eql (parse-integer awnser :junk-allowed t)
                                (month-number month))
                           t))))
      (list question test-fun correct-response wrong-response)))

   (create-question-template
    "Which month comes next?"
    (let* ((random-number (+ 1 (random 11)))
           (month (assoc random-number *months*))
           (next-month (assoc (+ 1 random-number) *months*))
           (question (format nil "Which month comes after ~A?" (month-name month)))
           (correct-response (format nil "That's correct!~%"))
           (wrong-response (format nil "No, that's wrong.. ~A comes after ~A.~%" (month-name month) (month-name next-month)))
           (test-fun (lambda (awnser) 
                       (if (string-equal awnser (month-name next-month))
                           t))))
      (list question test-fun correct-response wrong-response)))

   (create-question-template
    "Which month goes before?"
    (let* ((random-number (+ 2 (random 11)))
           (month (assoc random-number *months*))
           (last-month (assoc (- random-number 1) *months*))
           (question (format nil "Which month goes before ~A?" (month-name month)))
           (correct-response (format nil "That's correct!~%"))
           (wrong-response (format nil "No, that's wrong.. ~A goes before ~A.~%" (month-name last-month) (month-name month)))
           (test-fun (lambda (awnser) 
                       (if (string-equal awnser (month-name last-month))
                           t))))
      (list question test-fun correct-response wrong-response)))))

(defun random-question ()
  "Return a question at random"
  (funcall (random-item *question-templates*)))
  
(defun create-questions (number-of-questions)
  "Return a list of questions"
  (loop for y from 1 to number-of-questions
       collect (random-question)))

(defun mark-awnser (question awnser)
  "Take a question and awnser and return t if correct."
  (if awnser
      (let ((result (funcall (cadr question) awnser)))
        (if result
            (values result (caddr question))
            (values result (cadddr question))))
      (values nil (cadddr question))))

(defun right-awnsers (awnsers)
  "Return a count of how many awnsers where right."
  (count nil awnsers :key 'not))

(defun ad-banner ()
  "<script type='text/javascript'><!--
google_ad_client = 'pub-6037667691060767';
/* Lisp days - Try 1 */
google_ad_slot = '3672844700';
google_ad_width = 468;
google_ad_height = 15;
//-->
</script>
<script type='text/javascript'
src='http://pagead2.googlesyndication.com/pagead/show_ads.js'>
</script>")

(defun html-prompt (question)
  "Ask the user a question through a HTML form."
  (with-html-output-to-string (*standard-output* nil :indent t)
    (htm (:p (fmt "~A" (car question)))
         (:form :id "form" :action "/months" :method "post"
                (:input :id "guess" :name "guess" :size "30" :style "text-align:center" :autocomplete "off")
                (:br)
                (:input :type "submit" :name "submit" :value "Answer")))))

(defun snazy-prompt (question number)
  (with-html-output-to-string (*standard-output* nil :indent t)
    (htm (:div :id "prompt"
               (:h2 (fmt "Question ~A" number))
               (fmt "~A" (html-prompt question))))))

(defun show-score (awnsers questions)
  "Display a nice tally of the game's score"
  (with-html-output-to-string (*standard-output* nil :indent t)
    (when awnsers
      (loop for n from (- (length awnsers) 1) downto 0
         do (if (nth n awnsers)
                (htm (:b "*"))
                (htm (:b ".")))))
    (when (and questions
               (> (length questions) (length awnsers)))
      (loop for n from (+ 1 (length awnsers)) to (length questions)
         do (htm (:b "-" ))))
    (when (and (not questions)
               (not awnsers))
      "")))

(defun months-page ()
  "Function to create the month game page that's displayed."
  (let ((questions (session-value "questions"))
        (current-question (session-value "current-question"))
        (guess (post-parameter "guess"))
        (awnsers (session-value "awnsers")))
    (no-cache)
    (with-html-output-to-string (*standard-output* nil :indent t)
      (:html
       (:head
        (:title "Months of the Year Learning Game")
        (:link :type "text/css"
               :rel "stylesheet"
               :href "/lisp/template.css")
        (:script :type "text/javascript" 
                 :src "/lisp/include.js"))
       (:body :onload "setFocus();"
              (:center
               (:p (fmt "~A" (ad-banner)))
               (:h1 "Months of the Year Learning Game")
               (:br)
               (if (not questions)      ; New Game's starting
                   (progn
                     (htm (:p (:b "Welcome to the Month Learning Game!"))
                          (:p (:i "Try your best to awnser 10 questions about the different Months"))
                          (:br))
                     (start-session)
                     (setf (session-value :current-question) 0)
                     (setf (session-value :awnsers) nil)
                     (setf (session-value :questions) (create-questions 10))
                     (fmt "~A" (snazy-prompt (nth (session-value :current-question) (session-value :questions)) 1)))
                   (if (not (< 0 (length guess)))
                       (htm (:p (:b "Please Awnser!"))
                            (fmt "~A" (snazy-prompt (nth current-question questions) (+ 1 current-question))))
                       (multiple-value-bind (result output) ; Game's in progress
                           (mark-awnser (nth current-question questions) guess)
                         (push result (session-value :awnsers))
                         (push result awnsers)
                         (htm (:p (:i (fmt "'~A ~A'" (car (nth current-question questions)) guess)))
                              (:p (fmt "~A"  output)))
                         (incf current-question)
                         (incf (session-value :current-question))
                         (if (eql current-question (length questions)) ; Game's just finished
                             (progn
                               (htm (:p (:b (fmt "** You scored ~A out of ~A **" 
                                                 (right-awnsers awnsers) 
                                                 (length questions))))
                                    (:p (:a :href "/months" "Play again?")))
                               (delete-session-value :questions)
                               (delete-session-value :current-question)
                               (delete-session-value :awnsers))
                                        ;Game's still going, ask another question!
                             (fmt "~A" (snazy-prompt (nth current-question questions) (+ 1 current-question)))))))
               (fmt "~A" (show-score (session-value :awnsers) 
                                     (session-value :questions)))))))))

• It’s fairly flexible already but I want to be able to make totaly seperate quizes without rewriting stuff.
• I’m also not really sure about how I wrote the game logic inside the months-page function. It’s really messy but I don’t see how else to do it.
• I don’t like how creating the question templates looks so ugly.

I’m a bit stuck with how to improve the code now, could anyone give me any pointers?

Cheers, Dave.

The last few days I have been working on a small scraper script. I’m going to Canada soon and I wanted an email alert to warn me when on-line Visa applications open. I wanted the script to email me a nice message to show me what’s changed on the page and it to log what’s going on for my piece of mind.

It took a few days, it ended up getting far too complicated. Instead of writing a little script in Perl I ended up writing this Lisp monster that uses a library to parse the HTML into a tree, code to search the tree which got pretty hairy!

It works though, but it’s so horrible I’m too ashamed to even post it here. I’m going to rewrite it using CL-PPCRE (searching for a block of text with regexp instead of parsing the HTML as a tree (hoping it works) and then having to deal with a tree).

It was a good learning exercise but a pretty clear example of KISS. Oh well….

- Dave.

I ran into a problem today where my Slime connection would suddenly drop if I loaded a file that contained UTF characters.

Luckily the #lisp bods saved the day, here’s how you fix it:

1. Add (setq slime-net-coding-system ‘utf-8-unix) to your .emacs
2. Add the :coding-system “utf-8-unix” keyword parameter to your (swank:create-server) call

There’s more information available here.

Cheers, Dave.

I managed to get Weblocks installed today, it’s been a bit of a struggle but with a lot of help from these guys I got there.

If you are having troubles have a look at these posts:

1. [clbuild-devel] Problem installing Weblocks
2. [Weblocks] Problem installing Weblocks
3. [clbuild-devel] Problem installing Weblocks
4. [cl-markdown-devel] [clbuild-devel] Problem installing Weblocks
5. [clbuild-devel] [cl-markdown-devel] Problem installing Weblocks

I’m writing up what you need to do to get it installed and I’m about to actually give it a go now so I will post some more shortly. Cheers, Dave.

Here’s a guide to take a fresh Debian stable (etch) install and turn it into a viable Lisp web development environment. (Including Emacs22, SBCL, Slime, Hunchentoot, Apache2 all working together from boot)

Please note because this is aimed at a totally fresh Debian stable install you are going to need to be selective with the commands if it’s not a fresh install or if you are using a different version of Debian.

All the commands assume you are logged in as root on your soon-to-be web server.

Installation Steps

# Install Emacs 22
echo deb http://hype.sourceforge.jp/f etch backports >> /etc/apt/sources.list
wget http://hype.sourceforge.jp/A7F20B7E.gpg -O- | apt-key add -
apt-get update
apt-get install emacs22

# Install the other required packages
apt-get install darcs cvs subversion curl git-core cogito sbcl make gcc build-essential detachtty 

# Grab clbuild
cd /usr/src
darcs get http://common-lisp.net/project/clbuild/clbuild
cd clbuild && chmod +x clbuild

# Install the different bits and bobs with clbuild
./clbuild update sbcl
./clbuild compile-implementation sbcl
echo cl-unicode get_darcs http://common-lisp.net/~loliveira/ediware/cl-unicode >> projects
echo metabang-bind get_darcs http://common-lisp.net/project/metabang-bind >> projects
echo stefil get_darcs http://common-lisp.net/project/stefil/darcs/stefil >> projects
echo cffi get_darcs http://common-lisp.net/project/cffi/darcs/cffi >> projects
./clbuild build cl-unicode cl-ppcre hunchentoot vecto cl-who slime metabang-bind iterate stefil babel cffi

# Make a lisp image
./clbuild dumpcore --installed

# Setup lisp to start on boot
cd /etc/init.d
wget http://www.kzar.co.uk/lisp-install/lisp-boot
chmod a+x lisp-boot
cd /etc/rc2.d
ln -s ../init.d/lisp-boot S98lispboot
mkdir /var/run/lisp

# Add the lisp user for lisp to run as
adduser lisp-user
touch /var/log/detachtty.log
touch /var/log/lisp-app-dribble
chown lisp-user:lisp-user /var/log/detachtty.log
chown lisp-user:lisp-user -R /var/run/lisp
chown lisp-user:lisp-user /var/log/lisp-app-dribble

# Make it so lisp will start the webserver and swank server each time
cd /usr/src/clbuild/
mkdir /var/lisp && cd /var/lisp
wget http://www.kzar.co.uk/lisp-install/server.lisp
mkdir images && cd images
wget http://www.lisperati.com/lisplogo_alien_128.png
chmod g+w -R /var/lisp
chown -R lisp-user:lisp-user /var/lisp

# Grab Apache2 and set it up with modlisp
apt-get install apache2 cl-modlisp libapache-mod-lisp apache2-threaded-dev
cd /etc/apache2/sites-available/
rm default && wget http://www.kzar.co.uk/lisp-install/default
cd /etc/apache2/mods-enabled
wget http://www.kzar.co.uk/lisp-install/lisp.load
wget http://www.kzar.co.uk/lisp-install/lisp.conf
cd /usr/lib/apache2/modules
wget http://www.kzar.co.uk/lisp-install/mod_lisp2.so

# Get rid of the old SBCL that comes with Debain (Thanks Todd)
apt-get remove sbcl
echo SBCL_HOME=/usr/src/clbuild/target/lib/sbcl >> /etc/profile
ln -s /usr/src/clbuild/target/bin/sbcl /usr/bin/sbcl
ln -s /usr/src/clbuild/target/lib/sbcl /usr/local/lib/sbcl
cd /usr/src/clbuild/target/lib/sbcl && rm -r site-system
ln -s /usr/lib/sbcl/* .

# Start it all running
/etc/init.d/apache2 restart
/etc/init.d/lisp-boot start

# Set up emacs (Do as the user who will use emacs)
cd ~ && wget http://www.kzar.co.uk/lisp-install/.emacs

Usage

• Browse to http://SERVERNAME/lisp to view your website.
• Type emacs /var/lisp/server.lisp to start editing the little example page.
• Type M-x slime-connect RET RET in Emacs to connect to the running Lisp REPL

Notes

• Add your user to the lisp-user group to edit the files
• Make sure you have downloaded the .emacs for your user so slime-connect works properly

Leave a comment if you hit a problem and I’ll try and help - Dave.

Edit: Thanks to Todd for some good feedback, I have added an additional stanza of commands that helps get rid of Debian’s old SBCL version and let’s the nice new one still use some of the Debian installed cl package. (That’s the hope anyway, let me know if it worked for you / if there’s a better way to do that part)

I was reading Godel, Escher, Bach: An Eternal Golden Braid on the train and when reading about the MU puzzle I decided to give it a go. I wrote most of it there on my ‘lil eeepc but I did get a bit stuck with the recursion, it was hard to get the apply-rules function to stop once a path to the answer “MU” had been found and return it.

In the end with some help from the good folks in #emacs and #lisp I had it working here’s the code:

(defvar *path*)

(defun all-matches (string pattern &key (start 0))
  "Return a list of positions for all matches of the pattern in the string"
  (let ((match (search pattern string :start2 start)))
    (when match
      (append (list match)
              (all-matches string pattern :start (+ match 1))))))

(defun list-if (x)
  (when x 
    (list x)))

(defun replace-substr (string start end new)
  (concatenate 'string (subseq string 0 start) new 
               (subseq string end)))

(defun replace-all-once (string pattern new)
  (let ((matches (all-matches string pattern)))
    (remove-duplicates 
     (loop for match in matches
        collect (replace-substr string match (+ match (length pattern)) new))
     :test #'equal)))

(defun string-last (string)
  (aref string (1- (length string))))

(defun rule-1 (string)
  (when (eql (string-last string) #\I)
    (concatenate 'string string "U")))

(defun rule-2 (string)
  (when (eql (aref string 0) #\M)
    (if (> (length string) 1)
        (concatenate 'string string (subseq string 1))
        string)))

(defun rule-3 (string)
  (replace-all-once string "III" "U"))

(defun rule-4 (string)
  (replace-all-once string "UU" ""))

(defun apply-rules (string depth)
  "Return a list of axioms returned by the various rules"
  (if (or (< depth 1) *path*)
      nil
      (if (equal string "MU")
          (push "MU" *path*)
          (let ((results (append
                          (list-if (rule-1 string))
                          (list-if (rule-2 string))
                          (rule-3 string)
                          (rule-4 string))))
            (loop for match in results
               collect (append (list match) (apply-rules match (1- depth)))
               do (when (and match (equal (last *path*) (list match)))
                    (push string *path*)))))))

(defun find-mu (depth)
  (let (tree *path*)
    (setf tree (apply-rules "MI" depth))
    (if *path*
        (format t "The awnser is: ~a. ~%" *path*)
        (format t "Couldn't solve it by going through ~a levels of possibilites. ~%  Tree:~A" depth tree))))

(find-mu 5)

Now when Emacs ground to a halt trying to solve the puzzle, beach pointed out that it was actually impossible and it’s explained later in the book.. whoops! Anyway I thought it was a nifty little program so I thought I’d post it anyway.

(Try replacing “MU” with something that is possible to find to see it in action.)

Cheers, Dave.

Although quite pleased with my last experiment getting a web interface working I wanted to make it more powerful.

I decided the best way to go to avoid complexity was to parse input from the user so you could enter a date or a date range in any format you wanted and the program would hopefully understand what you meant. To do this I started to learn how to basic language parsers work and it seemed quite simple so I gave it a go.

It turned out to be a good challenge, I think I now finally ‘get’ Lisp macro’s now as well thanks to the guys in #lisp. It’s working pretty well, you can give it stuff like “next week” or “last month” or “16th September 2008 to today” or “12 03 2009″ etc etc.

Edit: Have a play with the demo!

Here’s the code so far:

(require :cl-ppcre)

(defpackage :disco-parser
  (:use :asdf :asdf-install :cl :cl-ppcre)
  (:export :make-rule
           :craft-rule
           :parse
           :split))

(in-package :disco-parser)

(defun do-rule-fun (name regexp string function)
"Search the string for the regexp and return the result of running the function on the matches as a token list"
  (let ((matches (all-matches regexp string)))
    (loop for (start end) on matches by #'cddr
       collect (list name start end 
                     (funcall function (format nil (subseq string start end)))))))

(defmacro make-rule (name regexp &body body)
  "Return a function that calls do-rule-fun taking a string to search as it's paramter. AKA return a regexp rule"
  `(let ((scanner (create-scanner ,regexp)))
     (lambda (string)
       (do-rule-fun ',name scanner string (lambda (,name) ,@body)))))

(defun flatten (tree)
  "Takes a tree and returns the tree flattened it into a list"
  (when tree
    (if (consp tree)
        (append (flatten (car tree)) (flatten (cdr tree)))
        (cons tree nil))))

(defmacro with-token ((&key (type nil) (start nil) (end nil) (value nil))
                      token &body body)
  "Take a token and some keywords and put the parts of the token into the keywords"
  `(let (,@(when type `((,type (first ,token))))
        ,@(when start `((,start (second ,token))))
        ,@(when end `((,end (third ,token))))
        ,@(when value `((,value (fourth ,token)))))
    ,@body))

(defun clash? (existing-tokens new-token)
  (when existing-tokens
    (with-token (:start new-start :end new-end) new-token
      (with-token (:start old-start :end old-end) (car existing-tokens)
        (if (or (> new-start old-end)
                (< new-end old-start))
            (if (consp (cdr existing-tokens))
                (clash? (cdr existing-tokens) new-token)
                nil)
            t)))))
                           
(defun remove-clashing-tokens (existing-tokens new-tokens)
  "Return the new-tokens list of tokens minus any that clashed with existing tokens"
  (let ((good-new-tokens))
    (dolist (new-token new-tokens)
      (if (not (clash? existing-tokens new-token))
          (push new-token good-new-tokens)))
    good-new-tokens))

(defun tokenise (string token-rules)
  "Takes a string and a list of token-rules and returns a list of tokens"
  (let (tokens)
    (dolist (rule token-rules)
      (setf tokens (append (remove-clashing-tokens tokens (funcall rule string))
                           tokens)))
    (sort tokens #'< :key #'cadr)))

(defun find-pattern (pattern token-list)
  "Take a token list and a pattern in it to match and it will return a list of matches"
  (let (match-position (start 0))  
    (loop while (setf match-position (search pattern (mapcar #'car token-list) :start2 start))
       do (setf start (+ 1 match-position))
       collect (loop repeat (length pattern)
                  for x = match-position then (+ x 1)
                  collect (nth x token-list)))))

(defun apply-rule-fun (pattern name func token-list)
  "Take a rule and 'run' it"
  (let ((new-tokens
         (loop for match in (find-pattern pattern token-list)
            collect (list name 
                          (cadr (car match))
                          (third (car (last match)))
                          (apply func (mapcar #'fourth match))))))
    (sort (append (remove-clashing-tokens new-tokens token-list) new-tokens) 
          #'< :key #'cadr)))
        
(defmacro craft-rule (pattern name &body body)
  "Macro that should make an easier interface to use than apply-rule-fun. Give it all the info appart from the list of tokens and it returns a function that will take the list of tokens"
  (loop for (key val) on pattern by #'cddr
     collect key into keys
     collect val into vals
     finally (return
               `(lambda (token-list)
                  (apply-rule-fun ',keys ',name
                                  (lambda ,vals ,@body) token-list)))))

(defun apply-logic-rules (token-list rules)
"Take some tokens and a list of logic rules and return the new token list"
  (let ((tokens token-list))
    (loop for rule in rules
       do (setf tokens (apply rule (list tokens))))
    tokens))

(defun parse (string token-rules logic-rules)
  "Take a string, the token and logic rules and return the tokens"
  (apply-logic-rules (tokenise string token-rules) logic-rules))

;; Todo
; 
; Sort out the naming of the various functions and rules
; e.g. what's the difference from a logic and token rule!?
;
; Write code to check gramitical correct-ness

(defvar *date-token-rules* 
  (list
   (make-rule day "[0-9]+rd" (parse-integer day :junk-allowed t))
   (make-rule day "[0-9]+th" (parse-integer day :junk-allowed t))
   (make-rule day "[0-9]+st" (parse-integer day :junk-allowed t))
   (make-rule day-of-week "(?i:Mon(day)?)" 1)
   (make-rule day-of-week "(?i:Tue(sday)?)" 2)
   (make-rule day-of-week "(?i:Wed(nesday)?)" 3)
   (make-rule day-of-week "(?i:Thu(rsday)?)" 4)
   (make-rule day-of-week "(?i:Fri(day)?)" 5)
   (make-rule day-of-week "(?i:Sat(urday)?)" 6)
   (make-rule day-of-week "(?i:Sun(day)?)" 7)
   (make-rule month "(?i:Jan(uary)?)" 1)
   (make-rule month "(?i:Feb(ruary)?)" 2)
   (make-rule month "(?i:Mar(ch)?)" 3)
   (make-rule month "(?i:Apr(il)?)" 4)
   (make-rule month "(?i:May)" 5)
   (make-rule month "(?i:Jun(e)?)" 6)
   (make-rule month "(?i:Jul(y)?)" 7)
   (make-rule month "(?i:Aug(ust)?)" 8)
   (make-rule month "(?i:Sep(tember)?)" 9)
   (make-rule month "(?i:Oct(ober)?)" 10)
   (make-rule month "(?i:Nov(ember)?)" 11)
   (make-rule month "(?i:Dec(ember)?)" 12)

   (make-rule date "(?i:[0-9]+[/\\ \-][0-9]+[/\\ \-][0-9]+)"
     (let* ((date-list (split "[/\\ \-]" "08/09/2008"))
            (day (parse-integer (car date-list)))
            (month (parse-integer (cadr date-list)))
            (year (parse-integer (caddr date-list))))
       (make-date day month year)))
  
   (make-rule date "(?i:Now)" 
     (get-universal-time))

   (make-rule date "(?i:Today)" 
     (get-universal-time))
 
   (make-rule date-range "(?i:This week)" 
     (with-date (:day-of-week day-of-week) (get-universal-time) 
       (cons
        (x-days (get-universal-time) (- day-of-week)) 
        (x-days (get-universal-time) (- 6 day-of-week)))))

   (make-rule date-range "(?i:Last week)"
     (with-date (:day-of-week day-of-week) (get-universal-time)
       (cons
        (x-days (get-universal-time) (- (+ day-of-week 7)))
        (x-days (get-universal-time) (- (- day-of-week) 1)))))

   (make-rule date-range "(?i:Next week)"
     (with-date (:day-of-week day-of-week) (get-universal-time)
       (cons
        (x-days (get-universal-time) (- 7 day-of-week))
        (x-days (get-universal-time) (+ 6 (- 7 day-of-week))))))

   (make-rule date-range "(?i:This month)" 
     (with-date (:month month :year year) (get-universal-time) 
       (cons
        (make-date 1 month year) (make-date (days-in-month month year) month year))))

   (make-rule date-range "(?i:Next month)" 
     (with-date (:month month :year year) (get-universal-time) 
       (let ((next-month (+ month 1)) (next-year year))
         (when (> next-month 12)
           (setf next-month 1)
           (setf next-year (+ year 1)))
         (cons
          (make-date 1 next-month next-year) (make-date (days-in-month next-month next-year) next-month next-year)))))

   (make-rule date-range "(?i:Last month)" 
     (with-date (:month month :year year) (get-universal-time) 
       (let ((last-month (- month 1)) (last-year year))
         (when (< last-month 1)
           (setf last-month 12)
           (setf last-year (- year 1)))
         (cons
          (make-date 1 last-month last-year) (make-date (days-in-month last-month last-year) last-month last-year)))))
   
   (make-rule date "(?i:start of month)"
     (with-date (:month month :year year) (get-universal-time)
         (make-date 0 month year)))

   (make-rule date "(?i:end of month)"
     (with-date (:month month :year year) (get-universal-time)
         (make-date (days-in-month month year) month year)))

   (make-rule date "(?i:end of year)"
     (with-date (:year year) (get-universal-time)
         (make-date (days-in-month 12 year) 12 year)))

   (make-rule date "(?i:start of year)"
     (with-date (:year year) (get-universal-time)
         (make-date 0 12 year)))

   (make-rule date "(?i:Tommorow)"
     (x-days (get-universal-time) 1))
  
   (make-rule date "(?i:Yesterday)"
     (x-days (get-universal-time) -1))

   (make-rule date-range "(?i:ddget)"
     (cons
      (x-days (x-working-days (x-days (get-universal-time) -1) 2) 1)
      (x-working-days (x-days (get-universal-time) -1) 3)))

   (make-rule year "[0-9]{4}" (parse-integer year :junk-allowed t))
   (make-rule number "[0-9]+" (parse-integer number :junk-allowed t))))


(defvar *date-logic-rules* 
  (list
   (craft-rule (month m day d year y) date (make-date d m y))
   (craft-rule (day d month m year y) date (make-date d m y))
   (craft-rule (date start range-seperator foo date end) date-range (make-date-range start end))
   (craft-rule (date start date end) date-range (make-date-range start end))))

(defun parse-date (string)
  "Take a string containing a date or range of dates and return some tokens"
  (parse string *date-token-rules* *date-logic-rules*))

(Feel free to use it for whatever you want.)

One thing I’m especially proud of is the way you make rules, you give the macro some regexp, a “name” symbol and some code to run and it returns to you a function which can then be called on a string to return any tokens found. It’s really nifty and lets you use pretty much the full power of the language inside each rule. Later on I will be able to add rules so it can handle stuff like “A week ago last Thursday” thanks to this power.

I’m now trying to figure out what makes it run so slowly (it takes a few seconds to come back with tokens on a fairly fast box). I think it’s to do with how I check for clashing tokens and remove them but I’m not sure exactly what the cause is. I have tried to use SBCL’s profiling tools but I have yet to make much sense of the output.

If anyone has any feedback on the code, or how I can make it run faster I’d appreciate it.

Edit: Thanks to the guys in #lisp (especially H4ns and rsynott) I have now fixed the speed issue. CL-PPCRE works by creating a ’scanner’ function for each regexp which works really fast, but this takes a little time to create. The idea being you create all the scanners at compile-time and then use them at run-time. Problem was with the way my rule creating macro worked it didn’t do this properly. Now the make-rule macro returns the code to create the scanner and then return the function using this scanner and the problem is solved. A massive speed increase with 1 extra line of code, not bad going!

When making the last lisp program I found it hard to visualise the working days between two dates. I ended up drawing these little sketches on a bit of paper to figure out if my program was doing the right thing or not!

Anyway I decided for my next project I would make a tool to display the dates for me. I am using Vecto library and so far I have found it to be awesome, really easy to use but powerful at the same time.

The code is still rough and ready but in a few hours I went from nothing to this:

To generate that image I just ran this code: (draw-date-range ‘(03 07 2008) ‘(7 07 2008) “2workingdays.png”)

Next up I am going to tidy it all up, fix a few bugs and then get it working with a web interface through Hunchentoot so anyone with a web browser can make their own.

When the code’s less thrown together I’ll share that too, Dave.

Edit:

I have been busy the last few evenings and I have got the Hunchentoot interface working. ‘ere’s a couple of screenshots:

before…

and after…

At work recently we found the need to check some dates in a database where correct, there’s a table that for any given date has the date two working days before and two working days after. It’s used to figure out when a transaction should be sent to the bank and to see when it should complete their end.

Anyway I have been trying to learn Lisp for a while so as a side project I decided to write something to generate a CSV of the required dates so I could check everything lined up and so that we have the next few years worth of dates ready.

Here’s the code, if you have any feedback I would greatly appreciate it as I am still really new to Common Lisp.

(defpackage :disco-date
  (:use :cl)
  (:export :date-range
           :format-date
           :work-day?
           :next-day
           :prev-day
           :day-name
           :split-by-one-space
           :with-date
           :read-date
           :date-within-range?     
           :date>
           :date>
           :make-date))

(in-package #:disco-date)

(defvar *day-names* '((01 . "Mon") (02 . "Tue") (03 . "Wed") (04 . "Thu")
                      (05 . "Fri") (06 . "Sat") (0 . "Sun")))

(defvar *bank-holidays* ())
(defvar *months* '((01 . 31) (03 . 31) (04 . 30) (05 . 31) 
                  (06 . 30) (07 . 31) (08 . 31) (09 . 30)
                  (10 . 31) (11 . 30) (12 . 31)))                      

(defmacro with-date ((&key (day '#:unused-day) (month '#:unused-month) (year '#:unused-year) 
                           (day-of-week '#:unused-day-of-week) (second '#:unused-second) (minute '#:unused-minute) 
                           (hour '#:unused-hour) (tz '#:unused-tz) (dst-p '#:unused-dst-p))
                     date &body body)
  "Take a date, split it up into it's parts and run the code in body."
  `(multiple-value-bind
         (,second ,minute ,hour ,day ,month ,year ,day-of-week ,dst-p ,tz)
       (decode-universal-time ,date)
     (declare (ignorable ,second ,minute ,hour ,day ,month ,year ,day-of-week ,dst-p ,tz))
     ,@body))

(defun leap-year? (year)
  "Take a year and return T if a leap year, otherwise NIL"
  (or (and (eql 0 (mod year 4)) (not (eql 0 (mod year 100))))
          (eql 0 (mod year 400))))

(defun days-in-month (month year)
  "Takes a month,year and returns the number of days in it"
  (if (not (eql month 2))
      (cdr (assoc month *months*))
      (if (leap-year? year)
          29
          28)))

(defun real-date? (day month year)
  "Take a day, month and year and return t if the date is valid, nil otherwise"
  (if (and (> day 0) (> month 0) (> year 1000)
           (<= month 12)
           (<= year 3000)
           (<= day (days-in-month month year)))
      t
      nil))

(defun make-date (day month year &optional (hour 0) (minute 0) (second 0))
  "Take the different parts of a date and return a universal date"
  (when (real-date? day month year) 
    (encode-universal-time second minute hour day month year)))

(defun gregorian-weekday (date)
; Credit to someone in #emacs (consolers I think but I forget)
  "Return the day of week for the date given, 0 indexed so 0 for Sunday, 1 for Monday etc"
  (with-date (:day day :month month :year year) date
    (mod (+ 0
            (* 365 (1- year)) (floor (1- year) 4) (- (floor (1- year) 100))
            (floor (1- year) 400) (floor (- (* 367 month) 362) 12) 
            (if (<= month 2) 
                0 
                (if (and (= (mod year 4) 0) (not (member (mod year 400) (list 100 200 300))))
                    -1 
                    -2)) 
            day) 
         7)))
  
(defun file-lines (path)
; Credit to http://www.cl-user.net/asp/html-docs/process-file-snippset
  "Sucks up an entire file from PATH into a list of freshly-allocated
      strings, returning two values: the list of strings and the number of
      lines read."
  (with-open-file (s path)
    (loop for line = (read-line s nil nil)
       while line
       collect line into lines
       counting t into line-count
       finally (return (values lines line-count)))))

(defun split-by-one-space (string)
; Credit to http://cl-cookbook.sourceforge.net/strings.html#reverse
  "Returns a list of substrings of string divided by ONE space each. Note: Two consecutive spaces will be seen as if there were an empty string between them."
  (loop for i = 0 then (1+ j)
     as j = (position #\Space string :start i)
     collect (parse-integer (subseq string i j) :junk-allowed t)
     while j))



(defun read-date (date-string)
  "Take a string containg a date and return the date structure, or NIL if the string is in the wrong format"
  (let ((loaded-date (split-by-one-space date-string)))
    (if (and (equal (length loaded-date) 3)
             (every 'numberp loaded-date)
             (real-date? (car loaded-date) (cadr loaded-date) (caddr loaded-date)))
        (make-date (car loaded-date) (cadr loaded-date) (caddr loaded-date))
        nil)))

(defun load-date (filename)
  "Take a filename and read a list of space seperated dates into a list, returns the list"
  (loop for line in (file-lines filename)
     collect (split-by-one-space line)))

(setf *bank-holidays* (load-date "/var/www/lisp/bank-holidays.txt"))

(defun bank-holiday? (date)
  "Return T if bank-holiday and nil otherwise"
  (with-date (:day day :month month :year year) date
    (find date *bank-holidays* :test #'equal)))

(defun next-day (date)
  "Take a date and return the next one"
  (with-date (:day day :month month :year year) date
    (if (not (eql day (days-in-month month year)))
        (make-date (+ 1 day) month year)
        (if (eql month 12)
            (make-date 1 1 (+ 1 year))
            (make-date 1 (+ 1 month) year)))))

(defun prev-day (date)
  "Take a date and return the previous one"
  (with-date (:day day :month month :year year) date
    (if (not (eql day 1))
        (make-date (- day 1) month year)
        (if (eql month 1)
            (make-date (days-in-month 12 year) 12 (- year 1))
            (make-date (days-in-month (- month 1) year) (- month 1) year)))))

(defun weekday? (date)
  "Return the day number if a weekday, otherwise NIL"
  (with-date (:day day :month month :year year) date
    (let ((day-of-week (gregorian-weekday date)))
      (if (and (< day-of-week 6) (> day-of-week 0))
          day-of-week
          NIL))))

(defun work-day? (date)
  "Take a Date and return t if it's a working day, NIL otherwise"
  (with-date (:day day :month month :year year) date
    (if (and (weekday? date)
             (not (bank-holiday? date)))
        T
        nil)))

(defun x-working-days (date x)
  "Take a date and return the date of x working days afterwards (negative number for previous)"
  (if (eql 0 x)
      date
      (let ((current-date date) (i -1))
        (loop 
           until (> i (abs x))
           when (work-day? current-date)
           do (incf i)
           when (> (abs x) i)
           do (setf current-date 
                    (if (> x 0)
                        (next-day current-date)
                        (prev-day current-date)))
           finally (return current-date)))))

(defun return-dates (date)
  "Take a 'valueDate' and return the send and completion date"
  (with-date (:day day :month month :year year) date
    (list date
          (if (work-day? date)
              (x-working-days date -2)
              (x-working-days date -1))
          (x-working-days date 2))))

(defun grab-dates (start-date end-date)
  "Get the send and completion date for every date in the range (inclusive), then return a list of 'um"
  (let ((current-date start-date))
    (loop until (equal current-date (next-day end-date))
       collect (return-dates current-date)
       do (setf current-date (next-day current-date)))))

(defun format-number (number)
  "Take a number and return it as a string, put a 0 infrount of it if it's single digits"
  (if (and (> number -1) (< number 10))
      (format nil "0~A" number)
      (format nil "~A" number)))

(defun format-date (date)
  "Take a date and return it as a nicely formatted string"
  (with-date (:day day :month month :year year) date
    (format nil "~A/~A/~A" (format-number day) (format-number month) year)))

(defun day-name (date)
  (with-date (:day day :month month :year year) date
    (cdr (assoc (gregorian-weekday date) *day-names*))))

(defun date> (first second)
  "Returns nil if second date is larger than first, otherwise it returns first"
  (with-date (:day first-day :month first-month :year first-year) first
    (with-date (:day second-day :month second-month :year second-year) second
      (if (equal (list first-day first-month first-year) (list second-day second-month second-year))
          nil
          (if (or (> first-year second-year)
                  (and (equal first-year second-year)
                       (> first-month second-month))
                  (and (equal first-year second-year)
                       (equal first-month second-month)
                       (> first-day second-day)))
              first
              nil)))))

(defun date< (first second)
  "Returns nil if second date is smaller than first, otherwise it returns first"
  (if (date> second first)
      first
      nil))

(defun date-within-range? (date max-date min-date)
  "Return date if it's in-between the min and max dates, inclusively"
  (if (and (or (equal date min-date) (date> date min-date))
           (or (equal date max-date) (date< date max-date)))
      date
      nil))
  
(defun date-range (start end)
  "Take two dates and return the inclusive range between them."
  (if (equal start end)
      (list start)
      (if (date> start end)
          (cons start (date-range (prev-day start) end))
          (cons start (date-range (next-day start) end)))))

Here is the bank-holidays1.txt I used, it contains all the UK bank holidays for the next few years.

Feel free to use the bits I wrote for anything you want, any feedback of how I could improve things would be really handy.

Cheers, Dave.

Edit:

I have taken some of the advice given in that comment and I have tweaked the code. (I noticed that the completion date needs to be 3 working days including the current day if it’s a working one where as the send date is always two working days earlier regardless if it’s on a weekend or not!?!) I also fixed a bug to get rid of a trailing space on all lines when printing the csv.

Interestingly I did actually find some mistakes after comparing my results with a dump of the database’s table, so it was worth checking after all!

Next up I am going to take up the suggestion of using decode-universal-time and encode-universal-time instead of my own way of storing dates. (Hopefully that will mainly involve changing the with-date macro, we will see..)

Edit2:

I have sorted out the with-date macro and other parts of the code so they now use proper universal time-stamps.

Also I have been forced to learn how packages work to get Hunchentoot ‘n co to work so I have now made this into a package that I can use from my other projects.