Posts tagged Project

Recently I needed to write some code to parse a binary protocol in PHP. Given a ASCII hex string representation of the message I needed to pull off bits and bytes, using them in lots of different ways.

Problem was that you have to read a byte at a time from the hex string, then manually shift bits each time to get what you want. This gets old and confusing very quickly! To solve this I've written bit-ratchet, a small class that lets you read bits and bytes from a hex string very simply.

The idea is you create a bit-ratchet object of your hex string. You then ask for bits and bytes, signed or not and bit-ratchet provides them whilst keeping track of your current position in the data. Additionally I added a few useful methods allowing you to skip, jump and pull off hex.

Things like scaling are left to the user, the one exception being signed numbers which are handled by bit-ratchet. I wanted to avoid creating a complex library like bindata, in my opinion although it's great the DSL it provides is constraining. Better to let the user use the host language and as far as possible stay out of the way!

It scratched my itch but let me know if you've got any ideas about how to expand on the abstraction.

Cheers, Dave

Hi everyone,

I recently tried to get Facebook birthdays and events to show up in my Google calendar. Everything I tried was broken, I just couldn't find something that worked properly.

Anyway I've made my own solution, it's available here: http://apps.facebook.com/calenderp

You have to click two install buttons (one with Facebook and one with Google) and then your calendar will be synced. It gets timezones right, has been translated into 3 languages so far and is starting to build up a fair following of users.

If you're interested in the technical side of things I've shared the source on GitHub https://github.com/kzar/CalenDerp . It uses Python, Google appengine, Facebook's graph API and the Google calendar API to sync everything.

Anyway let me know if you have feedback!

Cheers, Dave.

Edit: Also I'm looking for translators, get in touch if you can translate about 20 phrases into your language for me.

I have just released the first version of The Good JuJu List Machine. This is a viral list building application that's similar to Frank Kern's Good Karma List Machine.

If your not familiar with the idea basically it's a tool to help increase opt-ins to your mailing list virally. It offers free content as bait to get people to subscribe to your mailing list. Then when the subscriber confirms their email address they receive their prize and are also encouraged to share the link with their friends to receive even more free content.

I have listened to the people on the warrior forums and have implemented mostly everything that's been asked for, I know there where sticking points with a lot of the alternatives.

Features

• Wordpress plugin, written for version 3.0.1
• Supports any list provider like Aweber that can forward confirmed opt-ins to a "thank you" page
• Doesn't require password or anything else that could confuse or annoy potential subscribers.
• Free + opensource, I've coded it from scratch and released under the GPL.
• Completely customisable HTML for each page.
• Link reminder feature helps keep everyone happy.

Opt-in Process

The script works slightly differently to the alternatives, I've re-designed the process to reduce confusion and annoyance. First off I removed passwords, replacing them with a "private page link". I did this because we're trying to increase opt-ins not protect access to the bait content. Second I've re-structured things to allow integration with pretty much any list provider.

Download

• Latest version - .zip
• Latest version - .tar.gz
• Github Project

Demo / Screenshots

I developed the script on a new website I'm working on, the site isn't finished but you can give the JuJu list machine a test. Just opt-in at the top right and you will see how it all works. Also here's a quick screenshot , I'll add some more later.

Setup Instructions

Setting this thing up is easy:

1. Firstly download the script and extract the archive into your wp-content/plugins/ directory.
2. Now load your Wordpress admin, click 'Plugins' and then click 'Activate' below the 'Good JuJu List Machine' plugin.
3. Now click 'Good JuJu List Machine' under the Plguins menu on the left hand side.
4. OK, now follow the instructions on the JuJu page. (There's not much to do, just customise the templates, set 3 preferences and configure your email list.

Template codes

There are a few codes you can use in your templates to help insert the dynamic elements:

• %private-link% - The user's private page link.
• %referal-link% - The user's referral link.
• %referals-sofar% - How many referrals the user has racked up so far
• %basic-link% - Link to the free content.
• %extra-link% - Link to the extra free content given for the referrals.
• %email% - The user's email address.
• %content-links% - The links to the content, it includes either the basic links or extra links depending on their referals.
• %lost-link% - A link to the "I've lost my link" page.
• %outside-link% - A link to the front page of the script.
• %referals-needed% - The number of referrals needed for the extra bonus content.

Cheers, Dave

Edit: This didn't go down too well, the warrior forum guys just deleted my post and no one even tried it. The code isn't too nice, it was a very quick initial version I wanted to get out there to get feedback. It's not bad but it's got plenty of room for improvement, who knows maybe it will take off sometime. It definitely taught me that I don't want to work with the warrior forum crowd anyway.

Well hello and welcome to the fresh new blog. I wrote it using web.py, couchdb and python.

It's looking pretty nice, comments are outsourced to Disqus. It's all pretty simple, I am quite pleased with it though.

It now means I can quick edit code samples by adding a < code> tag around the sample. It escapes everything and renders it in a <pre> tag when being displayed and it even highlights everything using the prettifier Javascript module.

(Doesn't sound like much but in Wordpress I had to add an I-frame to each code post by hand, save the code to HTML with Emacs, upload the html and reference the file for the I-frame. It was the only way I could stop Wordpress from fucking up my code let alone getting it to display properly.)

Everything is stored in Couchdb, the URL's are sensible, it's all under my control and I generate an atom feed using libxml.etree.

I spent a while getting Nginx forwarding on all the old URLs properly. Also I have added some nice features to the admin system so it's easy for me to maintain everything.

After writing it though I got thoroughly annoyed with Python, I've decided to go back to learn Clojure, I've just bought a copy of Programming Clojure and in a few months I expect to re-write everything using that.

So anyway all the code is really messy for now but it works nicely and most important of all It's not wordpress.

Let me know if something breaks, if an old URL doesn't work or if there are any issues :) Also if anyone is interested how I coded parts of the blog just ask and I can explain.

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 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 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…