Feeds:
Posts
Comments

Archive for the ‘Scheme’ Category

Threading in MzScheme

This week I have been playing around with threading in MzScheme… I like it!

(thread (lambda () …))

is enough to create a thread and start it running.

You can use channels to pass data between threads safely with (make-channel), (channel-get <channel>) and (channel-put <channel> <data>).

Just to prove you can write Java in any language… say I wanted to have a connection manager. The API is pretty simple – I want to add connections and remove connections. Also, it might be useful to be able to start and stop the connection manager and display the number of connections. There are a number of ways I could implement this, e.g. have a global variable and synchronise access to put and get connections. Alternatively, I could have a thread that looks after connections and send messages to that thread via a channel. Just for fun, let me choose the second option.

The functionality is encapsulated and available through the following API.

(connection-manager-start)
(connection-manager-stop)
(connection-manager-clear-connections)
(connection-manager-show-connections)
(connection-add <input-port> <output-port>)
(connection-remove <input-port>)

If this was production code, I should put the code in a module and only make the above functions available using (provide…). Outside a module, we can of course by-pass the API and put messages in the channel directly.

;; Support function LOG

(define (pad n) (substring (number->string (+ n 100)) 1 3))

(define (now)
  (let* ((date (seconds->date (current-seconds)))
         (secs (date-second date))
         (mins (date-minute date))
         (hour (date-hour date)))
    (format "~a:~a:~a" (pad hour) (pad mins) (pad secs))))

(define (LOG . args)
  (printf "[ ~a ] : " (now))
  (for-each display args)
  (newline)
  (flush-output))

;; First of all, we define a struct for the connection which has
;; an input and an output port

(define-struct connection (input output))

;; Globals for the channel, and the thread - it is a singleton obviously

(define *connections-channel* (make-channel))
(define *connection-manager-thread* #f)

;; The actual manager function
;;   this constantly loops and accepts messages via *connections-channel*
;;   possible messages are:
;;     'stop, 'add-connection, 'remove-connection,
;;     'show-connection, 'clear-connections

(define (connection-manager)
  (letrec
      ((show-command
        (lambda (command)
          (LOG "Received command [" (symbol->string command) "]")))

       (show-connections
        (lambda (connections)
          (let* ((num (length connections))
                 (plural (not (= num 1))))
            (LOG "There "
                 (if plural "are " "is ")
                 num
                 " connection"
                 (if plural "s" "")))))

       (loop
        (lambda (connections)
          (let* ((command (channel-get *connections-channel*))
                 (head (car command)))
            (cond
             ((eq? head 'stop)
              (LOG "Connection manager stopping..."))
             ((eq? head 'add-connection)
              (loop (cons (cadr command) connections)))
             ((eq? head 'remove-connection)
              (let ((c (cadr command)))
                (LOG "Removing connection [" c "]")
                (loop (remove (lambda (e) (eqv? (connection-input e) c))
                              connections))))
             ((eq? head 'show-connections)
              (show-connections connections)
              (loop connections))
             ((eq? head 'clear-connections)
              (loop '()))
             (else
              (LOG "Error: unrecognised-command [" head "]")
              (loop connections)))))))

    (LOG "Connection manager starting...")
    (loop '())))

;; connection-manager-running? checks if the connection-manager
;; is currently running - it is a belt and braces effort

(define (connection-manager-running?)
  (and (thread? *connection-manager-thread*)
       (thread-running? *connection-manager-thread*)))

;; We always check if the connection-manager is running before
;; trying to send a message as (channel-put ...) waits until there
;; is a corresponding (channel-get ...) on another thread.  When
;; testing at the REPL, this can cause problems.  We could use an
;; asynch stream which wouldn't have this problem but I prefer
;; the explicit check

(define (connection-manager-send-message message)
  (if (connection-manager-running?)
      (channel-put *connections-channel* message)
      (begin
        (LOG "WARN - Connection manager is not currently running")
        #f)))

;; The actual API functions.  Most of these simply check if the
;; connection manager is running, and if so, put the appropriate
;; message in the channel.

(define (connection-manager-start)
  (if (connection-manager-running?)
      (LOG "WARN - The connection manager is already running")
      (set! *connection-manager-thread* (thread connection-manager))))

(define (connection-manager-stop)
  (connection-manager-send-message (list 'stop))
  (set! *connection-manager-thread* #f))

(define (connection-manager-clear-connections)
  (connection-manager-send-message (list 'clear-connections)))

(define (connection-manager-show-connections)
  (connection-manager-send-message (list 'show-connections)))

(define (connection-add input-port output-port)
  (connection-manager-send-message
   (list 'add-connection (make-connection input-port output-port))))

(define (connection-remove input-port)
  (connection-manager-send-message (list 'remove-connection input-port)))

;;; Connection Manager Test

;; The test...

(define (test-connection-manager)
  (connection-manager-start)
  (connection-manager-clear-connections)
  (connection-manager-show-connections)
  (connection-add 1 2)
  (connection-manager-show-connections)
  (connection-remove 1)
  (connection-manager-show-connections)

  (time
   (begin
     (do ((i 0 (+ i 1)))
         ((= i 100000) #t)
       (connection-add 1 2))
     (connection-manager-show-connections)))

  (connection-manager-stop))

;; (test-connection-manager)

Read Full Post »

I was unable to find any mention of a function for copying files in the Chicken documentation. However, the Chicken source does have a copy-file function in chicken-setup.scm. It is somewhat brittle as it uses the shell, relying on the fact that you are running the function from the same shell you used to build Chicken.

$ find . | egrep '.scm$' | xargs grep 'copy-file'

(define *windows-shell* (memq *windows* '(msvc mingw32)))
(define *copy-command* (if *windows-shell* 'copy "cp -r"))

(define (copy-file from to)
  (let ((from (if (pair? from) (car from) from))
	(to (if (pair? from) (make-pathname to (cadr from)) to)) )
    (ensure-directory to)
    (run (,*copy-command* ,(quotewrap from) ,(quotewrap to)) ) ) )

A solution with the Win32 function CopyFile would be more robust but would probably need some work to do a recursive copy. I don’t need the recursive functionality and fortunately, it is straight-forward to wrap using Chicken’s foreign function interface. I created a file called win32_lib.impl to keep all the syntax highlighting working.

#include "Windows.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

char* w32_error_message()
{
    char* buffer;

    FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER
                  | FORMAT_MESSAGE_FROM_SYSTEM
                  | FORMAT_MESSAGE_IGNORE_INSERTS,
                  NULL,
                  GetLastError(),
                  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
                  (LPTSTR) &buffer,
                  0, NULL);

    buffer[strlen(buffer) - 2] = '';
    return buffer;
}

int w32_copy_file(const char* file1,
                  const char* file2,
                  int fail_if_exists)
{
    return CopyFile(file1, file2, fail_if_exists);
}
</pre>

The wrapper from Chicken is trivial:
(define-extension win32_lib)

#>
#include "win32_lib.impl"
<#

(define w32-error-message
  (foreign-lambda c-string* "w32_error_message"))

(define w32-copy-file
  (foreign-lambda int "w32_copy_file" c-string c-string int))

The makefile takes care of making a .dll so we can load it into csi (the Chicken REPL) for testing purposes.

all: win32_lib.dll prog.exe

prog.exe: main.scm win32_lib.scm win32_lib.impl
	csc -c main.scm
	csc -c win32_lib.scm
	csc -o prog.exe main.o win32_lib.o

win32_lib.dll: win32_lib.scm
	csc win32_lib.scm -dynamic -dll

clean:
	rm *.o prog.exe win32_lib.dll

And finally the test harness:

(declare (uses win32_lib))

(define args (cdr (argv)))
(display args)
(newline)

(define (wrap-copy-file file1 file2)
  (let ((r (w32-copy-file (car args) (cadr args) 1)))
    (if (= r 0)
        (printf "[~a]~n" (w32-error-message))
        (printf "Success!~n"))))

(wrap-copy-file (car args) (cadr args))

Read Full Post »

I had the pleasure of setting up a new Win32 development environment recently. After installing emacs, the first thing to do was to get MinGW and MSYS installed for the C and C++ compilers and a semi-reasonable shell.

MinGW can be downloaded here but it is slightly difficult to see the latest files for downloading. I think it would be better if they put clear links to at least the latest versions of MinGW and MSYS at the top of the page. Anyway, here they are (as of today – 4th March 2007).

I don’t really want to code in C or C++ outside of work if I can really help it, so the next thing to do is to install a friendlier language. I’m quite comfortable with scheme so I’ll use Chicken for the ability to create Win32 executables although in reality there are many acceptable alternatives here. Chicken is available here and it requires CMake to build.

As of version 2.6, Chicken seems to have improved significantly since I last looked at it. Only a C compiler is required to build it rather than an existing Chicken compiler which makes the bootstrapping procedure somewhat easier. I installed it to c:/chicken, set the PATH and CHICKEN_HOME environment variables and compiled my first test program on this machine. Very nice and straightforward.

Read Full Post »

One of the problems given to solve in HTDP was to write a program that solved the 8 queens problem, that is, to place 8 queens on a standard chess board so that none of them are attacking each other. I quite enjoyed working through this, and came up with something that used a straight size 64 scheme vector to represent the board which I thought would be reasonably efficient.

First of all, as encouraged by HTDP, there were the functions to manipulate and display the board:

(define-struct board (squares size))

(define (display-board b) …)

(define (coord->index x y n) …)
(define (board-ref b x y) …)

;; Constructors
(define (build-board n f) …)
(define (empty-board n) …)

and then the methods suggested within the book to solve the problem.

I’ve attached the code at the end along with fairly naive translations into Ocaml and C++.

The surprising thing to me though is that vast differences in speed. The Ocaml runs around 15 times faster than the scheme, and the C++ runs around 20 times faster than the Ocaml. Now, to some people, this might suggest that C++ is much faster than Ocaml which in turn is much faster than PLT Scheme. However, the wealth of information around on the net leads me to believe that this is not true. I therefore conclude that I am not very good at writing efficient scheme or efficient Ocaml.

I can see that there are minor algorithmic differences between the code. In particular, the C++ uses out-of-bound data rather than a Some / None type as in the Ocaml. Additionally, the C++ uses simple machine integers to represent the square types. It is difficult to believe that this accounts for the difference though, in which case, what am I doing wrong?

$ time mzscheme -qu queens.ss
cpu time: 1235 real time: 1281 gc time: 453
51886 recursive calls to (placements …)
mzscheme -qu queens.ss 0.00s user 0.00s system 0% cpu 1.468 total

$ ocamlopt -noassert -unsafe -ccopt -O3 -ccopt -fomit-frame-pointer q.ml -o q.exe
$ time ./q.exe
n==10
./q.exe 0.00s user 0.00s system 0% cpu 1.000 total

$ time ./a.exe 8 1000 | grep -v Qu
./a.exe 8 1000 0.00s user 0.00s system 0% cpu 4.938 total

mzscheme code

(module queens mzscheme

  (require (lib "42.ss" "srfi"))

  (define-struct board (squares size))

  ;; 28.2.1

  (define (display-board b)
    (printf "~n")
    (let ((s (board-squares b))
          (n (board-size b)))
      (do-ec (: y n)
             (: x n)
             (begin
               (display (if (= x 0) "(" " "))
               (display (vector-ref s (coord->index x y n)))
               (when (= x 7) (printf ")~n"))))))

  ;; 28.2.2

  (define (coord->index x y n) (+ (* y n) x))

  (define (board-ref b x y)
    (vector-ref (board-squares b) (coord->index x y (board-size b))))

  (define (build-board n f)
    (let ((size (* n n)))
      (make-board
       (vector-of-length-ec size
                            (:range i size)
                            (f (remainder i n) (quotient i n)))
       n)))

  (define (empty-board n)
    (build-board n (lambda (x y) #f)))

  ;; 28.2.3

  (define-struct posn (x y))

  (define (threatened? queen square)
    (let ((x1 (posn-x queen))
          (y1 (posn-y queen))
          (x2 (posn-x square))
          (y2 (posn-y square)))
      (or (= x1 x2)
          (= y1 y2)
          (= (- x2 x1) (- y2 y1))
          (= (- x1 y2) (- x2 y1)))))

  ;; 28.2.4

  (define init-pos (make-posn 0 0))

  (define (add-queen board p)
    (let ((s (board-size board))
          (qx (posn-x p))
          (qy (posn-y p)))
      (build-board s (lambda (x y)
                       (let ((c (board-ref board x y)))
                         (cond ((and (= x qx) (= y qy)) 'Qu)
                               (c c)
                               ((threatened? p (make-posn x y)) 'At)
                               (else #f)))))))

  (define (invalid-posn? board p)
    (not (eq? (board-ref board (posn-x p) (posn-y p)) #f)))

  (define (next-valid-posn board p)
    (let ((s (board-size board)))
      (let loop ((x (+ 1 (posn-x p)))
                 (y (posn-y p)))
        (cond ((>= x s) (loop 0 (+ y 1)))
              ((>= y s) #f)
              (else (let ((new-p (make-posn x y)))
                      (if (invalid-posn? board new-p)
                          (loop (+ x 1) y)
                          new-p)))))))

  (define (display-posn p)
    (if (posn? p)
        (printf "(~a, ~a)~n" (posn-x p) (posn-y p))
        (printf "Not posn~n")))

  (define *count-placements* 0)

  (define (placement board p rem)
    (set! *count-placements* (+ *count-placements* 1))
    (cond ((= rem 0) board)
          ((not p) #f)
          ((invalid-posn? board p) (placement board (next-valid-posn board p) rem))
          (else (let loop ((cur-pos p))
                  (if (not cur-pos) #f
                      (let ((possible-board (placement (add-queen board cur-pos) init-pos (- rem 1))))
                        (if possible-board possible-board
                            (loop (next-valid-posn board cur-pos)))))))))

  (define (solve-for-queens n)
    (set! *count-placements* 0)
    (time (display-board (placement (empty-board n) init-pos n)))
    (printf "~a recursive calls to (placements ...)~n"
            *count-placements*))

  (solve-for-queens 8 )

  (provide (all-defined)))

;; (require "queens.ss")

Ocaml code

type square = Queen | Safe | Attacked;;
type posn = Posn of int * int;;
type board = Board of square array * int;;

let string_of_square = function
  | Queen -> "Qu"
  | Safe -> "#f"
  | Attacked -> "At";;

let index_of_coord x y n = (y*n) + x;;

let coord_of_index i n =
  let y = i / n in (i - y*n, y);;

let board_ref b x y =
  match b with
      Board (squares, size) -> Array.get squares (index_of_coord x y size);;

let print_board board =
  match board with
      None -> print_string "Nonen"
    | Some (Board (_, s) as b) ->
	let b_x = (s - 1) in
	let rec loop x y =
	  if y >= s then ()
	  else if x >= s then loop 0 (y+1)
	  else begin
	    print_string (if x = 0 then "(" else " ");
	    let i = index_of_coord x y s in
	      print_string (string_of_square (board_ref b x y));
	      if x = b_x then print_string ")n";
	      loop (x+1) y
	  end
	in loop 0 0;;

let build_board n f =
  Board (Array.init (n * n) f, n);;

let empty_board n =
  build_board n (fun i -> Safe);;

let is_threatened queen square =
  match queen, square with
      (x1, y1), (x2, y2) ->
	x1 == x2 ||
	  y1 == y2 ||
	  (x2 - x1) == (y2 - y1) ||
	  (x1 - y2) == (x2 - y1);;

let add_queen board p =
  match board, p with
      Board (squares, size), (qx, qy)
	-> build_board size (fun i ->
			       let c, qi = (Array.get squares i), index_of_coord qx qy size in
				 if i == qi then Queen
				 else if c != Safe then c
				 else if (is_threatened p (coord_of_index i size)) then Attacked
				 else Safe);;

let is_invalid_posn board p =
  match p with
      None -> true
    | Some (Posn (x, y) as posn) -> board_ref board x y != Safe;;

let next_valid_posn board p =
  match board, p with
      _, None -> None
    | Board (_, size), Some (Posn (x, y)) ->
	let rec loop x y =
	  if x >= size then loop 0 (y+1)
	  else if y >= size then None
	  else let new_posn = Posn (x, y) in
	    if is_invalid_posn board (Some new_posn) then loop (x+1) y
	    else Some new_posn
	in loop (x+1) y;;

let valid_board b =
  match b with
      Some (Board (_, _)) -> true
    | _ -> false;;

let init_pos = Some (Posn (0,0));;

let rec placement board posn rem =
  match board, posn with
      None, _ -> None
    | _, None -> None
    | Some (Board (squares, size) as b), Some (Posn (x, y) as p) ->
	if rem = 0 then board
	else if is_invalid_posn b posn then placement board (next_valid_posn b posn) rem
	else let rec loop curpos =
	  match curpos with
	      None -> None
	    | Some (Posn (x, y)) ->
		let possible_board = (placement
					(Some (add_queen b (x, y)))
					init_pos
					(rem - 1)) in
		  if valid_board possible_board then possible_board
		  else loop (next_valid_posn b curpos)
	in loop posn;;

let do_times f n =
  Printf.printf "n==%dn" n;
  let rec loop n =
    f ();
    if n != 1 then loop (n - 1)
  in loop n;;

let solve_queens n =
  (placement (Some (empty_board n)) init_pos n);;

do_times (fun () -> (solve_queens 8 )) 10;;

print_board (solve_queens 8 );;

C++ code

#include <vector>
#include <string>
#include <iostream>

using namespace std;

namespace Status {
    static const int Qu      = 0;
    static const int Safe    = 1;
    static const int At      = 2;
    static const int Invalid = 3;

    static string mapping[] = { "Qu", "#f", "At", "I" };
    string string_of_square(int i) { return mapping[i]; }
}

using namespace Status;

typedef std::vector<int> Squares;

struct Posn
{
    int x_;
    int y_;

    Posn(int x, int y) : x_(x), y_(y) { }
    bool is_invalid() const { return (x_ < 0) && (y_ < 0); }
};

const Posn init_pos(0, 0);

class Board
{
private:
    Squares squares_;
    int size_;

    int index_of_coord(int x, int y) const { return y * size_ + x; }

public:
    Board(int size) : squares_((size * size), Safe), size_(size) { }
    int ref(int x, int y) const { return squares_[index_of_coord(x, y)]; }
    int ref(const Posn& p) const { return ref(p.x_, p.y_); }

    void display() const {
        for (int y = 0; y < size_; ++y) {
            for (int x = 0; x < size_; ++x) {
                cout << ((x == 0) ? "(" : " ");
                cout << string_of_square(ref(x, y));
            }
            cout << ")n";
        }
    }

    template<typename T>
    static Board build_board(int size, T f) {
        Board b(size);
        for (int y = 0; y < size; ++y) {
            for (int x = 0; x < size; ++x) {
                b.squares_[b.index_of_coord(x, y)] = f(x, y);
            }
        }

        return b;
    }

    Board add_queen(const Posn& p) const;

    Posn next_valid_posn(const Posn& p) const {
        for (int y = p.y_; y < size_; y++) {
            for (int x = p.x_ + 1; x < size_; x++) {
                if (ref(x, y) == Safe) { return Posn(x, y); }
            }
        }

        return Posn(-1, -1);
    }

    static Board invalid_board() {
        static Board b(1);
        b.squares_[0] = Invalid;
        return b;
    }

    bool is_invalid() const { return squares_[0] == Invalid; }

    static Board placement(const Board& b, const Posn& p, int rem) {
        if (b.is_invalid()) { return b; }
        else if (p.is_invalid()) { return invalid_board(); }
        else if (rem == 0) { return b; }
        else if (b.ref(p) != Safe) {
            return placement(b, b.next_valid_posn(p), rem);
        } else {
            Posn curpos = p;
            while (! curpos.is_invalid()) {
                Board b1 = placement(b.add_queen(curpos), init_pos, rem - 1);

                if (b1.is_invalid()) {
                    curpos = b.next_valid_posn(curpos);
                } else {
                    return b1;
                }
            }
            return invalid_board();
        }
    }
};

bool is_threatened(int x1, int y1, int x2, int y2)
{
    return x1 == x2 ||
        y1 == y2 ||
        (x2 - x1) == (y2 - y1) ||
        (x1 - y2) == (x2 - y1);
}

class add_queen_fobj
{
public:
    add_queen_fobj(const Board& b, const Posn& p) : b_(b), p_(p) { }

    int operator()(int x2, int y2) {
        int c = b_.ref(x2, y2);
        int x1 = p_.x_;
        int y1 = p_.y_;

        if ((x1 == x2) && (y1 == y2)) { return Qu; }
        else if (c != Safe) { return c; }
        else if (is_threatened(x1, y1, x2, y2)) { return At; }
        else { return Safe; }
    }

private:
    const Board& b_;
    const Posn& p_;
};

Board Board::add_queen(const Posn& p) const {
    return build_board(size_, add_queen_fobj(*this, p));
}

void usage(const char* prog)
{
    cout << "usage: " << prog << " [size] [times]n";
    exit(1);
}

int main(int argc, char* argv[])
{
    if (argc != 3) { usage(argv[0]); }
    int size = atoi(argv[1]);
    int times = atoi(argv[2]);

    Board b(size);
    Board result(1);
    for (int i = 0; i < times; ++i) {
        result = Board::placement(b, init_pos, 8 );
    }

    result.display();
}

Read Full Post »

Pattern matching in scheme

I’ve been looking for an excuse for familiarising myself with PLT scheme’s pattern matching library for a while. Finally, I came across an article about implementing a basic Computer Algebra System. The Ocaml source code can be found here. Using the pattern matching library it can be fairly mechanically translated into scheme.

(require (lib "match.ss"))

(define-struct plus (e1 e2))
(define-struct times (e1 e2))
(define-struct divide (e1 e2))

(define MP make-plus)
(define MT make-times)
(define MD make-divide)

(define simplify
  (match-lambda
   (($ times a ($ plus b c)) (MP (simplify (MT a b)) (simplify (MT a c))))
   (($ divide ($ divide a b) ($ divide c d)) (MD (simplify (MT a d))
                                                 (simplify (MT b c))))
   (e e)))

(define expr->list
  (match-lambda
   (($ times a b) (list (expr->list a) '* (expr->list b)))
   (($ plus a b) (list (expr->list a) '+ (expr->list b)))
   (($ divide a b) (list (expr->list a) '/ (expr->list b)))
   (e e)))

(define expr (make-times 'x (make-plus 'y 'z)))

(printf "orig: ~a~n" (expr->list expr))
(printf "new: ~a~n" (expr->list (simplify expr)))

(let ((e (MD (MD 'a 'b) (MD 'c 'd))))
  (printf "div: ~a -> ~a~n" (expr->list e) (expr->list (simplify e))))

If I had come across this post a few weeks ago, I probably wouldn’t have even considered the implementation using define-struct. HTDP has certainly improved the way I think about coding scheme now and indeed several of the exercises in the book involve constructing various scheme evaluators that embed a simple CAS like the one above.

The article concludes with the following quote:

“…as you can see, Ocaml’s variant types and pattern matching are a perfect fit for the problems a programmer writing a CAS would face. In fact, few other languages, with the possible exception of Haskell, would have fit this problem as well.”

It seems that with the appropriate extensions, scheme can be a good fit for this type of problem too.

Read Full Post »

Learning to program functionally

A major problem I’ve found with learning scheme in isolation is that it is quite easy to pick up the syntax and then start programming in with a heavy C++ accent. Although this demonstrates the flexibility of scheme, it is not what I’m really after. The question is, how to learn to write in a good style. I can think of a number of possibilities:

  1. Keep writing programs in scheme and hope my style will improve
  2. Read books that specifically teach good scheme style
  3. Read real world code written in scheme

I’ve been inspired to work through some of the exercises in HTDP from various posts I’ve read on Lambda the Ultimate. So far, the book advises a similar approach to designing programs as I have seen before: decide on your data structures before writing the code and define the data structures using (define-struct …). I’ve found it a useful exercise to write functions that convert the data structures into lists that could be evaluated to re-create the original data. Here is an example, more or less from chapter 17.

(define-struct expr (op a1 a2))
(define-struct f-app (name expr))
(define-struct fn (name arg body))

(define f (make-fn 'f 'x (make-expr '+ 3 'x)))
(define i (make-fn 'i 'v (make-expr '+ (make-expr '* 'v 'v) (make-expr '* 'v 'v))))

;;; Convert expressions to lists

(define (add-quote s)
  (string->symbol (string-append "'" (symbol->string s))))

(define (expr->list e)
  (cond ((expr? e) (list 'make-expr
                         (add-quote (expr-op e))
                         (expr->list (expr-a1 e))
                         (expr->list (expr-a2 e))))
        ((f-app? e) (list 'make-f-app
                          (add-quote (f-app-name e))
                          (expr->list (f-app-expr e))))
        ((symbol? e) (add-quote e))
        ((number? e) e)
        (else (raise (format "Error: invalid type ~a" e)))))

(define (fn->list f)
  (list 'make-fn
        (add-quote (fn-name f))
        (add-quote (fn-arg f))
        (expr->list (fn-body f))))

(for-each (lambda (x) (display (format "~a~%" (fn->list x))))
          (list f i))

Read Full Post »

Data Structures in (Mz)Scheme

I sometimes forget how useful the STL is in C++. It provides a good range of data structures that fit the majority of my programming needs. One that I use very frequently is map<T>. Map provides a nice ordered collection which I can insert an element into and delete an element from, in order log(N) time where N is the number of elements. Out of the box, neither Perl, nor R5RS scheme give me the same structure. I’m sure it is available from CPAN for Perl and there are countless examples of implementing similar structures on top of scheme’s wonderful heterogenous trees. However, I’m far to lazy to write my own code that is at such a low level so it was very nice to find the galore library of data structures by Jens Axel S√łgaard.

I was curious to do some comparisons in performance between C++ and scheme here so I quickly coded up some tests to insert a million elements into a leftist heap compared to inserting a million elements into a map. Admittedly that isn’t an apples to apples comparison but that isn’t much of a consideration for me!

The C++ code was nice and concise:

#include <map>
#include <string>
#include <iostream>

using namespace std;

string s()
{
    char buffer[6];

    for (int i = 0; i < 5; ++i) {
        buffer[i] = static_cast<char>((rand() % 26) + 97);
    }
    buffer[5] = 0;

    return string(buffer);
}

int main()
{
    cout << s() << endl;
    map<string, int> m;
    for(int i = 0; i < 1000000; ++i) {
        m[s()] = 1;
    }
}

The scheme was a bit longer but I had tried to do it a different way and I think it is quite elegant too:

(module test-heap mzscheme

  (require (prefix s: (lib "67.ss" "srfi")))
  (require (prefix s: (lib "69.ss" "srfi")))

  (require (prefix heap: "heap.ss"))

  (define (print-ln . args)
    (for-each display args)
    (newline)
    (flush-output))

  (define compare-fn s:string-compare)

  (define (random-string len)
    (list->string
     (let loop ((i len) (l '()))
       (if (= i 0) l
           (loop (- i 1)
                 (cons (integer->char
                        (+ (random 26) 97)) l))))))

  (define random-string-gen-reset! #f)

  (define random-string-gen
    (let ((max-strings 1000))
      (set! random-string-gen-reset!
            (lambda (max) (set! max-strings max)))
      (lambda (len)
        (if (= max-strings 0) #f
            (begin
              (set! max-strings (- max-strings 1))
              (random-string len))))))

  (define (populate-heap n)
    (random-string-gen-reset! n)
    (let loop ((h (heap:empty compare-fn))
               (s (random-string 5)))
      (if s (loop (heap:insert s h) (random-string-gen 5)) h)))

  (define (test:performance)
    (time
     (random-seed 17)
     (print-ln "Starting...")
     (print-ln (heap:find-min (populate-heap 1000000)))
     (print-ln "Finished!")))

  (provide (all-defined)))

;; (require test-heap)
;; (test:performance)

I always put a couple of lines at the bottom of my scheme modules that are commented out so that I can execute them within emacs and find out if the whole module works. Does anyone else do this?

Initially when testing I benchmarked the C++ at a bit more than 7 seconds and the scheme at around 21 seconds which I thought was pretty good. However, now I come back to it the scheme is taking closer to a minute which I suspect means that somehow it isn’t triggering the new JIT compiler for the 350 series.

Read Full Post »

« Newer Posts - Older Posts »

Follow

Get every new post delivered to your Inbox.