A Monad for concurrency

This code is an attempt to port the Haskell code in A poor man’s concurrency monad to OCaml.

The main idea here, is about using a monadic interface to compose (CPS’d) functions. The resulting program can be run concurrently by interleaving and evaluating, on-demand, its constituents.

module Conc = 
struct
  type action = Atom of zaction
                | Fork of (zaction * zaction)
                | Stop
  and zaction  = action lazy_t
 
  (* CPS monad *)
  (* type 'a t = ('a -> action) -> action *)
  let bind f k = fun c -> f (fun a -> k a c)
  let return x = fun c -> c x  
 
  let atom f = fun c -> Atom (lazy (let b = f () in c b))
  let action f = f (fun () -> Stop)
  let fork f = fun c -> Fork (lazy (action f), lazy (c ()))
  let par m1 m2 = fun c -> Fork (lazy (m1 c), lazy (m2 c)) 
  let stop = fun c -> Stop
  let rec round = function
    | [] -> ()
    | (x::xs) -> match x with
        | Atom th -> let y = Lazy.force th in round (xs @ [y])
        | Fork (a1, a2) -> round (xs @ [Lazy.force a1; Lazy.force a2])
        | Stop -> round xs
 
  let run m = round [action m]
end
 
open Conc
 
(* given f and a number n, returns f composed with itself
   n times *)
let rec loop f = function
  | 0 -> stop
  | n -> bind f (fun () -> loop f (n-1))
 
(* example 1, prints "start", then prints the words "cat" 
   and "fish", interleaved, 10 times*)
let write1 s = atom (fun _ -> print_string s)
let example1 : ((unit -> action) -> action) = 
  bind (write1 "start>>>") 
    (fun _ -> bind (fork (loop (write1 "cat") 10)) 
       (fun _ -> (loop (write1 "fish") 10)))
 
 
let explode s =
  let rec exp i l =
    if i < 0 then l else exp (i - 1) (s.[i] :: l) in
  exp (String.length s - 1) []
 
(* write2: string -> ('a -> action) -> action
   prints each character one after the other *)
let write2 s = 
  let rec write2_aux = function
    | []    -> atom (fun _ -> ())
    | c::cs -> bind (atom (fun _ -> print_char c)) 
                    (fun _ -> write2_aux cs)
  in write2_aux (explode s)
 
(* write2: given a string, returns a CPSed function
   which prints each character one after the other *)
let example2 : ((unit -> action) -> action) = 
  bind (write2 "start>>>") 
    (fun _ -> bind (fork (loop (write2 "cat") 10)) 
       (fun _ -> (loop (write2 "fish") 10)))
 
let _ = 
  run example1; 
  print_newline ();
  run example2

Dataflow variables in Erlang

Implementing dataflow variables in Erlang, as library, is oddly easy.

Here is the whole code:

-module(prog).
 
-export([set/1, get/1, main/0]).
 
-define(DF_SET(Exp), prog:set(fun() -> Exp end)).
-define(DF_GET(Var), prog:get(Var)).
 
%% Creates a new dataflow var
set(Fun) ->
    spawn(fun() -> Res = Fun(), resolved(Res) end).
 
%% Loop to keep the result accessible
resolved(Res) ->
    receive
        {get, Ref, Pid} -> Pid ! {value, Ref, Res}
    end,
    resolved(Res).
 
%% Blocks until the future has evaluated
get(Var) ->
    Ref = make_ref(),
    Var ! {get, Ref, self()},
    receive
        {value, Ref, Res} -> Res
    end.
 
%% Time consuming friend
fib(0) -> 0;
fib(1) -> 1;
fib(N) when N > 1 -> fib(N-1) + fib(N-2).
 
main() ->
    X = ?DF_SET(fib(30)),
    Y = ?DF_SET(fib(20)),
    io:format("Computation starts, we do something else in the meantime...~n"),
    io:format("Accessing the result will block until it's resolved~n"),
    io:format("Result is: ~w ~n", [?DF_GET(X) + ?DF_GET(Y)]),
    io:format("Subsequent accesses will be instantaneous~n").

How does it work ?

We can implement a dataflow variable with an Erlang process, because:

  1. Erlang processes are really cheap, so we can afford to spawn one for each variable.
  2. a process can block to wait for a specific message. We use this to block the current process when we ‘look up’ a variable whose value is not yet available.

Breaking it down

To create a dataflow variable, you provide a computation:

X = prog:set(fun() -> fib(30) end)

This spawns a process p which starts executing fib(30) right away (see Res = Fun() in set(Fun)).

When the current process try to access X’s value:

Result = prog:get(X)

it sends a lookup message to p:

 X ! {get, Ref, self()}

and blocks (because of receive ... end) until p responds.

If p is not done computing the result of fib(30), the message sits in its mailbox.

When p is done,  it enters an infinite loop (the resolved function), and responds to pending / incoming lookups.

Syntax

We can improve syntax slightly with some help from the following macros:

-define(DF_SET(Exp), prog:set(fun() -> Exp end)).
-define(DF_GET(Var), prog:get(Var)).

we can now write

X = ?DF_SET(Exp)

instead of

X = prog:set(fun() -> Exp end)

and

?DF_GET(X)

instead of

prog:get(X)

Straight-line program interpreter

Chapter 1 of the Tiger book

type id = string
 
type binop = Plus | Minus | Times | Div
 
type stm = CompoundStm of stm * stm
	 | AssignStm of id * exp
	 | PrintStm of exp list
 
and exp = IdExp of id
	| NumExp of int
        | OpExp of exp * binop * exp
        | EseqExp of stm * exp
 
(* 
prog:
a = 5 + 3; 
b = (print [a, a-1]; 10 * a);
print b;
*)
let prog = 
 CompoundStm(
   AssignStm("a", 
             OpExp(NumExp 5, Plus, NumExp 3)),
   CompoundStm(
     AssignStm("b",
       EseqExp(PrintStm[IdExp "a"; OpExp(IdExp "a", Minus, NumExp 1)],
               OpExp(NumExp 10, Times, IdExp "a"))),
     PrintStm[IdExp "b"]))
 
 
(* 1: maxargs *)
let rec maxargs stm = 
  match stm with
    | CompoundStm (s1, s2) -> max (maxargs s1) (maxargs s2)
    | AssignStm (_, e) -> maxargs_exp e
    | PrintStm l -> let max_aux i e = max i (maxargs_exp e)
                    in let maxsub = List.fold_left max_aux  0 l
                    in max (List.length l) maxsub
and maxargs_exp exp =
  match exp with
    | IdExp _ -> 0
    | NumExp _ -> 0
    | OpExp (e1, _, e2) -> max (maxargs_exp e1) (maxargs_exp e2)
    | EseqExp (s, e) -> max (maxargs s) (maxargs_exp e)
 
 
(* 2: interpreter *)
type table = (id * int) list 
 
let rec lookup id env =
  match env with
    | [] -> raise Not_found
    | (x,v)::_ when x = id -> v
    | _::p -> lookup id p 
 
let set x v env = (x, v) :: env
 
let apply op v1 v2 = 
  match op with
    | Plus -> v1 + v2
    | Minus -> v1 - v2
    | Times -> v1 * v2
    | Div -> v1 / v2
 
let rec interp_stm expr env =
  match expr with 
    | CompoundStm (s1, s2) -> let env' = interp_stm s1 env
                              in interp_stm s2 env'
    | AssignStm (id, expr') -> let res, env' = interp_exp expr' env
                               in set id res env
    | PrintStm exprs -> 
      let print_exp env exp = 
        let v, env' = interp_exp exp env
        in print_string (string_of_int v ^ " "); env'   
      in let env' = List.fold_left print_exp env exprs
         in print_string "\n"; env'
 
and interp_exp expr env = 
  match expr with
    | IdExp id -> lookup id env, env 
    | NumExp n -> n, env
    | OpExp (e1, op , e2) -> let v1, env1 = interp_exp e1 env
                             in let v2, env2 = interp_exp e2 env1
                                in apply op v1 v2, env2
    | EseqExp (s, e) -> let env' = interp_stm s env 
                        in interp_exp e env'
 
let _ = 
  print_endline (string_of_int (maxargs prog)); (* => 2 *)
  interp_stm prog []                            (* => 8 7\n 80 *)

Set ADT in OCaml

In chapter 2 of Okasaki’s book, ML’s module system is used to implement an abstract polymorphic Set datatype. We parameterize our set implementation over a “comparable” interface that the set elements must implement.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
(* "comparable" interface *)
module type Ord =
sig
  type t
  val lt : t -> t -> bool
  val lte : t -> t -> bool
  val eq : t -> t -> bool
end
 
(* implementation of Ord for integers *)
module IntOrd : Ord with type t = int =
struct
  type t = int
  let lt = (<)
  let lte = (<=)
  let eq = (=)
end
 
(* Set interface *)
module type Set =
sig
  (* abstract element and set type *)         
  type elem 
  type set  
  (* set operations *)
  val empty : set
  val insert : elem -> set -> set
  val member : elem -> set -> bool
end
 
(* implementation of a set paramterized over Ord *)
module UnbalSet(Elt : Ord) : Set with type elem = Elt.t =
struct
  type elem = Elt.t
  type 'a tree = 
      Leaf 
    | Node of 'a tree * 'a * 'a tree
  type set = elem tree 
 
  let empty = Leaf
  let rec insert x = function
      Leaf -> Node (Leaf, x, Leaf)
    | Node (a, y, b) as s -> 
        if Elt.lt x y then Node (insert x a, y, b)
        else if Elt.lt y x then Node (a, y, insert x b) 
        else s
 
  let rec member x = function
      Leaf -> false
    | Node (a, y, b) ->
        if Elt.lt x y then member x a               (* two comparisons *)
        else if Elt.lt y x then member x b
        else true
end
 
(* instanciation of a set of comparable integers *)
module IntSet = UnbalSet(IntOrd)

Exercise 2.1 asks to optimize the member operation, by assuming that equality is uncommon we can mostly get away with only one comparison, comparing for equality only when we reached the end of a branch (worst case is now d+1 instead of 2*d comparisons, where d is the depth of the tree):

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
module type Ord =
sig
  type t
  val lt : t -> t -> bool
  val lte : t -> t -> bool
  val eq : t -> t -> bool
end
 
module IntOrd : Ord with type t = int =
struct
  type t = int
  let lt = (<)
  let lte = (<=)
  let eq = (=)
end
 
module type Set =
sig
  type elem
  type set
  val empty : set
  val insert : elem -> set -> set
  val member : elem -> set -> bool
end
 
module UnbalSet(Elt : Ord) : Set with type elem = Elt.t =
struct
  type elem = Elt.t
  type 'a tree = 
      Leaf 
    | Node of 'a tree * 'a * 'a tree
  type set = elem tree 
 
  let empty = Leaf
  let rec insert x = function
      Leaf -> Node (Leaf, x, Leaf)
    | Node (a, y, b) as s -> 
        if Elt.lt x y then Node (insert x a, y, b)
        else if Elt.lt y x then Node (a, y, insert x b) 
        else s
 
  let member x s = 
    let rec member_aux x s z =
      match s with
          Leaf -> x = z  (* comparing for equality when reaching a leaf *)
        | Node(a, y, b) -> 
            if Elt.lt x y then member_aux x a z   (* only one comparison *)
            else member_aux x b y
    in
      match s with
          Leaf -> false
        | Node(_, y, _) -> member_aux x s y             
end
 
module IntSet = UnbalSet(IntOrd)

Loops and state with pure functions

How would you write a loop in Python without ‘for/while’ ?

this:

i = 0
while i < 10:
   print i
   i = i +1

can be replaced by a recursive function like this:

def f(i):
   if i < 10: 
       print i
       f(i+1)
 
f(0)

In fact we can do to other variables what we’ve just done with the loop counter i, use a function parameter to pass new values

j = []
i = 0
while i < 10:
   j.append(i)
   i = i +1
 
print j

becomes

def f(i, j):
   if i < 10:  
       return f(i+1, j + [i])
   else:
       return j
 
print f(0, [])

So functions let us loop and change state.
While these transformations are pretty simple, they can be tricky to apply on a bigger piece of code…

Here is the Python code I wanted to rewrite:

def tokenize(s):
    "Convert a string into a list of tokens."
    return s.replace('(',' ( ').replace(')',' ) ').split()
 
def read_from(tokens):
    "Read an expression from a sequence of tokens."
    if len(tokens) == 0:
        raise SyntaxError('unexpected EOF while reading')
    token = tokens.pop(0)
    if '(' == token:
        L = []
        while tokens[0] != ')':
            L.append(read_from(tokens))
        tokens.pop(0) # pop off ')'
        return L
    elif ')' == token:
        raise SyntaxError('unexpected )')
    else:
        return token
 
print read_from(tokenize("(*(+ 3 4)(+ 6 7))"))

And here is the version without loop construct and mutation…

def tokenize(s):
    "Convert a string into a list of tokens."
    return s.replace('(',' ( ').replace(')',' ) ').split()
 
def parse_fun(tokens):
    _, ast = parse_fun_aux(tokens)
    return ast
 
def parse_fun_aux(tokens):
    if len(tokens) == []:
        raise SyntaxError('unexpected EOF')
    if tokens[0] == '(' :
        return loop(tokens[1:],[])
    elif tokens[0] == ')' :
        raise SyntaxError('unexpected )')
    else:
        return (tokens[1:], tokens[0])
 
def loop(tokens, ast):
    if tokens[0] == ')':
        return (tokens[1:], ast)
    else:
        tokens_left, token = parse_fun_aux(tokens)
        return loop(tokens_left, ast + [token])
 
print parse_fun(tokenize("(*(+ 3 4)(+ 6 7))"))

Memoizing recursive functions

A memoized function, avoids recomputing previous results by looking them up in a table (this only makes sense for functions without side-effects).

Memoizing recursive functions can be a bit tricky, let’s take the exponential fibonacci function as an example:

function fib(x) {
  if (x < 2)
     return x
  else
     return fib(x-2) + fib(x-1)
}
 
print(fib(100)) // this will time out !

we add a table to fibmem to cache the results of fib (note that fib references fibmem in the recursive call, no memoization would take place otherwise).

function fib(x) {
  if (x < 2)
     return x
  else
     return fibmem(x-2) + fibmem(x-1)
}
 
var cache = {}
function fibmem(x) {
  if (x in cache)
     return cache[x]
  else {
     var res = fib(x)
     cache[x] = res   
     return res
  }
}
 
print(fibmem(100))

All is well, but what about writing a function doing the memoization for us (we’ll just consider one-argument functions here) ?

Here’s a first attempt, given a function f, we return a new function that holds a reference to a lookup table and to the function f when we need to compute a result for the first time

function fib(x) {
  if (x < 2)
     return x
  else
     return fib(x-2) + fib(x-1)
}
 
function memoize(f) {
  var cache = {}
  return function(x) {
    if (x in cache)
       return cache[x]
    else {
       var res = f(x)
       cache[x] = res   
       return res
    }
  }
}
 
var fibm = memoize(fib)
print(fibm(100)) // this will time out

Uh oh!
The call to f, on line 14, escapes out of the memoized function, never to return. No memoization occurs.

How can we make f reference its memoized-self (like we did with fib and fibmem above) ?
By assigning the memoized function to the fib identifier !

function fib(x) {
  if (x < 2)
     return x
  else
     return fib(x-2) + fib(x-1)
}
 
function memoize(f) {
  var cache = {}
  return function(x) {
    if (x in cache)
       return cache[x]
    else {
       var res = f(x)
       cache[x] = res   
       return res
    }
  }
}
 
fib = memoize(fib)
print(fib(100))

Let’s recap:

1) A recursive function references itself with a name, here the name fib points to the fibonacci routine.

2) The memoize function returns another function that captures the name of the routine to be memoized (and the name of the lookup table).

3) When we call memoize over fib, the name captured references the unmemoized fibonacci routine.

4) When we assign memoize(fib) to fib, we make the captured fib name point to the memoized function.

Applying the memoized fibonacci function to a number results in a series of mutually recursive calls between the original (now nameless) fibonacci routine and the memoized routine.

Now if you want to read about a really fancy way to achieve the same results, check this article about a memoizing Y combinator.

Publié dans Uncategorized

Dynamic programming

Assembly lines in CLRS (page 326)

Recursive solutions

(use-syntax (ice-9 syncase))
 
;; memoizing macro
(define-syntax memoize
  (syntax-rules ()
    ((_ f)
     (let ((memo
            (lambda (f)
              (let ((t (make-hash-table)))
                (lambda args
                  (let ((res (hash-ref t args)))
                       (if res
                           res
                           (let ((res (apply f args)))
                                (hash-set! t args res)
                                res))))))))
       (set! f (memo f))
       f)))) 
 
;; Assembly lines
(define dag
  ;; [station time [(station . transfer-cost)]]
  '((0 0 ((1 . 2) (8 . 4)))   ;; station 0 is the source
    (1 7 ((2 . 0) (9 . 2)))   ;; station 1
    (2 9 ((3 . 0) (10 . 3)))  ;; station 2
    (3 3 ((4 . 0) (11 . 1)))  ;; station 3
    (4 4 ((5 . 0) (12 . 3)))  ;; station 4
    (5 8 ((6 . 0) (13 . 4)))  ;; station 5
    (6 4 ((7 . 3)))           ;; station 6
    (7 0 ())                  ;; station 7 is the sink
    (8 8 ((9 . 0) (2 . 2)))   ;; station 8
    (9 5 ((10 . 0) (3 . 1)))  ;; station 9
    (10 6 ((11 . 0) (4 . 2))) ;; station 10
    (11 4 ((12 . 0) (5 . 2))) ;; station 11
    (12 5 ((13 . 0) (6 . 1))) ;; station 12
    (13 7 ((7 . 2)))))        ;; station 13
 
;; Accessors
(define get-station car)
(define get-time cadr)
(define goes-to caddr)
(define get-transfer cdr)
 
(define previous-stations
  (lambda (station)
    (filter
     (lambda (s)
       (ormap (lambda (p) (= (car p) station)) (goes-to s)))
     dag)))
 
(define ormap
  (lambda (f lst)
    (if (null? lst)
        #f
        (or (f (car lst))
            (ormap f (cdr lst))))))
 
;; recursive computation of minimum time to a station
(define shortest-time-to
  (lambda (station)
    (let ((previous (previous-stations station)))
      (if (null? previous)
          0
          (apply min (map (time-through station) previous))))))
 
(define log
  (lambda (station v)
    (display (format #f "time at station ~a : ~a\n" station v))
    v))
 
(define time-through
  (lambda (station)
    (lambda (node)
      (log station
           (+ (shortest-time-to (get-station node))
              (get-time node)
              (get-transfer (assq station (goes-to node))))))))
 
;; exponential
(display "EXPONENTIAL:\n")
(display (shortest-time-to 7))
 
 
;; memoized
(display "\n\nMEMOIZED:\n")
(display ((memoize shortest-time-to) 7))

Iterative solution

(use-modules (srfi srfi-1))
 
(define lines
  '((9  9  12 12)
    (9  11 5  7)
    (3  4  6  4)
    (4  6  4  6)
    (8  10 5  8)
    (4  5  7  11)
    (3  3  2  2)))
 
(define opt-time
  (lambda (t z)
    (let* ((t1 (car t))
           (t2 (cadr t))
           (t3 (caddr t))
           (t4 (cadddr t))
           (z1 (car z))
           (z2 (cadr z))
           (a  (min (+ z1 t1) (+ z2 t2)))
           (b  (min (+ z1 t4) (+ z2 t3))))
      (list a b)))) 
 
(define min-time
  (lambda ()
    (apply min (fold opt-time '(0 0) lines))))
 
(display (min-time))
Publié dans Uncategorized

CPS traversals

(define (traversal type l cont)
     (if (null? l)
        (cont '())
        (traversal 
         type
         (caddr l)
         (lambda (xs)
           (traversal 
            type
            (cadddr l) 
            (lambda (ys)
              (cont 
               (cond ((eq? type 'in)
                      (append xs (list (cadr l)) ys))
                     ((eq? type 'pre)
                      (append (list (cadr l)) xs ys))
                     (else
                      (append xs ys (list (cadr l))))))))))))
 
(define (in-order tree f)
  (traversal 'in tree f))
 
(define (pre-order tree f)
  (traversal 'pre tree f))
 
(define (post-order tree f)
  (traversal 'post tree f))
 
(define tree 
  '(n 1 
      (n 2 
         (n 3 () ()) 
         (n 4 () ())) 
      (n 5 
         (n 6 () ())
         (n 7 () ()))))
 
(define (print-nodes xs) 
  (map display xs)
  (newline))
 
(in-order tree print-nodes)
(pre-order tree print-nodes)
(post-order tree print-nodes)
Publié dans Uncategorized

Towers of Hanoi, iteratively

The classic recursive solution

(define hanoi
  (lambda (n a b c)
    (cond ((> n 0)
           (hanoi (- n 1) a c b)
           (display (format #f "~a ==> ~a\n" a c))
           (hanoi (- n 1) b a c)))))
 
(hanoi 3 #\A #\B #\C)

The CPS version

(define hanoi-cps
  (lambda (n a b c k)
    (if (<= n 0)
        (k)
        (hanoi-cps (- n 1) a c b
                   (lambda ()
                     (display (format #f "~a ==> ~a\n" a c))
                     (hanoi-cps (- n 1) b a c k))))))
 
(hanoi-cps 3 #\A #\B #\C (lambda () #f))

After Registerization

(use-syntax (ice-9 syncase))
 
;; Borrowing some pattern matching code ===========================
;;; Code written by Oleg Kiselyov
;; (http://pobox.com/~oleg/ftp/)
;;;
;;; Taken from leanTAP.scm
;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log
 
(define-syntax pmatch
  (syntax-rules (else guard)
    ((_ (rator rand ...) cs ...)
     (let ((v (rator rand ...)))
       (pmatch v cs ...)))
    ((_ v) (error 'pmatch "failed: ~s" v))
    ((_ v (else e0 e ...)) (begin e0 e ...))
    ((_ v (pat (guard g ...) e0 e ...) cs ...)
     (let ((fk (lambda () (pmatch v cs ...))))
       (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk))))
    ((_ v (pat e0 e ...) cs ...)
     (let ((fk (lambda () (pmatch v cs ...))))
       (ppat v pat (begin e0 e ...) (fk))))))
 
(define-syntax ppat
  (syntax-rules (_ quote unquote)
    ((_ v _ kt kf) kt)
    ((_ v () kt kf) (if (null? v) kt kf))
    ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf))
    ((_ v (unquote var) kt kf) (let ((var v)) kt))
    ((_ v (x . y) kt kf)
     (if (pair? v)
       (let ((vx (car v)) (vy (cdr v)))
         (ppat vx x (ppat vy y kt kf) kf))
       kf))
    ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))
 
;;======================================================== 
 
(define n* #f)
(define a* #f)
(define b* #f)
(define c* #f)
(define k* #f)
 
(define empty-k 
  (lambda ()
    '(empty-k)))
 
(define print-k
  (lambda (n a c b k)
    `(print-k ,n ,a ,b ,c ,k)))
 
(define  apply-k
  (lambda ()
    (pmatch k*
      (('empty-k) #f)
      (('print-k ,n ,a ,b ,c ,k)
       (display (format #f "~a ==> ~a\n" a c))
       (set! n* (- n 1))
       (set! a* b)
       (set! b* a)
       (set! c* c)
       (set! k* k)
       (hanoi-reg)))))
 
(define hanoi-reg
  (lambda ()
    (if (<= n* 0)
        ( apply-k)
        (begin
          (set! k* (print-k n* a* c* b* k*))
          (let ((c c*))
            (set! c* b*)
            (set! b* c))     
          (set! n* (- n* 1))
          (hanoi-reg)))))
 
(define init-hanoi
  (lambda (n a b c)
    (set! n* n)
    (set! a* a)
    (set! b* b)
    (set! c* c)
    (set! k* (empty-k))
    (hanoi-reg)))
 
(init-hanoi 3 #\A #\B #\C)

After Trampolining

(use-syntax (ice-9 syncase))
 
;; Borrowing some pattern matching code ===========================
;;; Code written by Oleg Kiselyov
;; (http://pobox.com/~oleg/ftp/)
;;;
;;; Taken from leanTAP.scm
;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log
 
(define-syntax pmatch
  (syntax-rules (else guard)
    ((_ (rator rand ...) cs ...)
     (let ((v (rator rand ...)))
       (pmatch v cs ...)))
    ((_ v) (error 'pmatch "failed: ~s" v))
    ((_ v (else e0 e ...)) (begin e0 e ...))
    ((_ v (pat (guard g ...) e0 e ...) cs ...)
     (let ((fk (lambda () (pmatch v cs ...))))
       (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk))))
    ((_ v (pat e0 e ...) cs ...)
     (let ((fk (lambda () (pmatch v cs ...))))
       (ppat v pat (begin e0 e ...) (fk))))))
 
(define-syntax ppat
  (syntax-rules (_ quote unquote)
    ((_ v _ kt kf) kt)
    ((_ v () kt kf) (if (null? v) kt kf))
    ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf))
    ((_ v (unquote var) kt kf) (let ((var v)) kt))
    ((_ v (x . y) kt kf)
     (if (pair? v)
       (let ((vx (car v)) (vy (cdr v)))
         (ppat vx x (ppat vy y kt kf) kf))
       kf))
    ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))
 
;;======================================================== 
 
(define n* #f)
(define a* #f)
(define b* #f)
(define c* #f)
(define k* #f)
(define pc* #f)
(define done* #f)
 
(define empty-k
  (lambda ()
    '(empty-k)))
 
(define print-k
  (lambda (n a c b k)
    `(print-k ,n ,a ,b ,c ,k)))
 
(define apply-k-tramp
  (lambda ()
    (pmatch k*
      (('empty-k)
       (set! done* #t))
      (('print-k ,n ,a ,b ,c ,k)
       (display (format #f "~a ==> ~a\n" a c))
       (set! n* (- n 1))
       (set! a* b)
       (set! b* a)
       (set! c* c)
       (set! k* k)
       (set! pc* hanoi-tramp)))))
 
(define hanoi-tramp
  (lambda ()
    (if (<= n* 0)
        (set! pc* apply-k-tramp)
        (begin
          (set! k* (print-k n* a* c* b* k*))
          (let ((c c*))
            (set! c* b*)
            (set! b* c))
          (set! n* (- n* 1))
          (set! pc* hanoi-tramp)))))
 
(define trampoline
  (lambda ()
    (if (not done*)
      (begin
      	(pc*)
      	(trampoline)))))
 
(define init-hanoi-tramp
  (lambda (n a b c)
    (set! n* n)
    (set! a* a)
    (set! b* b)
    (set! c* c)
    (set! k* (empty-k))
    (set! done* #f)
    (set! pc* hanoi-tramp)
    (trampoline)))
 
(init-hanoi-tramp 3 #\A #\B #\C)

Conversion to C

#include <stdio.h>
#include <stdlib.h>
 
static void hanoi();
 
typedef struct cont_r *cont;
struct cont_r {
  int n;
  char a;
  char b;
  char c;
  struct cont_r *k;
};
 
typedef enum enum_e { FALSE, TRUE} enum_t; 
 
void (*pc)();
int n;
char a;
char b;
char c;
cont k;
enum_t done;
 
void apply_k(){
  cont tmp;
  if(k == NULL)
    done = TRUE;
  else {
    printf("%c ==> %c\n", k->a, k->c);
    n = k->n - 1;
    a = k->b;
    b = k->a;
    c = k->c;
    tmp = k;
    k = k->k;
    free(tmp);
    pc = hanoi;
  }
}
 
cont make_k(int n, char a, char c, char b, cont k2){
  cont k3 = malloc(sizeof *k3);
  k3->n = n;
  k3->a = a;
  k3->b = b;
  k3->c = c;
  k3->k = k2;
  return k3;
}
 
void hanoi(){
  char tmp;
  if(n == 0){
    pc = apply_k;
  }
  else {
    k = make_k(n, a, c, b, k);
    tmp = c;
    c = b;
    b = tmp;
    n = n - 1;
    pc = hanoi;
  }
}
 
void trampoline(){
  while(!done){
    pc();
  }
}
 
void init_hanoi(int n2, char a2, char b2, char c2){
  n = n2;
  a = a2;
  b = b2;
  c = c2;
  k = NULL;
  done = FALSE;
  pc = hanoi;
  trampoline();
} 
 
int main () {
  k = malloc(sizeof *k);
  init_hanoi(3,'A','B','C');
  free(k);
  return 0;
}

Run

Publié dans Uncategorized

Docstring Scheme macro

(use-syntax (ice-9 syncase))
 
;; define/doc macro
;; (define/doc funcname 
;;    (lambda args
;;        "Some docstring..."
;;        ...))
(define-syntax define/doc
  (syntax-rules ()
    ((_ name docstring exp)
     (begin
       (define name exp)
       (if (string? docstring)
         (doc-set! 'name docstring))))))
 
;; reading and writing the docstrings
(use-modules (srfi srfi-11))
 
(define *doc-table* (make-hash-table))
(define doc 
  (lambda (name)
    (let ((docstring (hash-ref *doc-table* name)))
      (if docstring
          docstring
          (printf "no documentation available for ~a\n" name)))))
 
(define doc-set! 
  (lambda (name text) 
    (hash-set! *doc-table* name text)))
 
;; user function with a docstring
(define/doc fib
  "Fibonacci function"
  (lambda (n)
    (if (< n 2)
        n
        (+ (fib (- n 1))  (fib (- n 2))))))
 
;; looking up a function's docstring
(display (doc 'fib))
(newline)
(display (fib 10))
Publié dans Uncategorized