*scratch*

vijay's weblog

Lazy Evaluation

This post is about lazy evaluation in Motto. As everything else, lazy evaluation can be accomplished without adding new syntax to the language. Code blocks and the bang (!) procedure is all that we need. As an example, consider the following procedure that generates an infinite sequence of numbers:

> [def n [n n 1 + integers]] def integers

integers is a procedure that returns a procedure. The returned procedure, when executed, will leave a copy of the argument on the stack and call integers again with the argument incremented by 1. This will leave a new procedure on the stack that will return this incremented value and so on. All this happens with no explicit management and modification of state. Let us see how integers can be used to produce a sequence, given a value to start with:

> 10 integers ! ! ! ! ! ! .p
10 11 12 13 14 15
> .c

;; or using the `times` procedure:
> 0 integers [!] 10 times .p
0 1 2 3 4 5 6 7 8 9

The following procedure shows how we could transform a lazy sequence by filtering out elements using a predicate:

> [def predic
   [! def n def i self def next-i
    i predic ? [i @n] [@n next-i]]] def filter

;; Filter even integers out:
> 0 integers @is-odd filter def p [p] 10 times .p
1 3 5 7 9 11 13 15 17 19
> .c

;; Filter odd integers out:
> 0 integers @is-even filter def p [p] 10 times .p
0 2 4 6 8 10 12 14 16 18

(This example is based on the code in Section 4.2.5 of R7RS.).

Job scheduler

This post describes a simple job scheduler. Each job description consists of a procedure and some ticks into the future. The scheduler will pick up the job after the given ticks (seconds) and run the procedure. A job description is represented using the following structure. (All code in Spark-Scheme.):

(define-struct job (run-at proc))

There is a fixed size vector that is used to store the jobs.

(define max-jobs 10)
(define jobs (make-vector max-jobs ()))

The index on which a job get stored is calculated as:

(remainder (+ (current-seconds) ticks) max-jobs)

The job is added to a list at the resulting index. The following procedure contain the complete logic for scheduling a job:

(define (schedule-job ticks job-proc)
  (let* ((run-at (+ (current-seconds) ticks))
         (job (make-job run-at job-proc))
         (index (remainder run-at max-jobs))
         (q (vector-ref jobs index)))
       (vector-set! jobs index (cons job q))))

The scheduler wakes up for each second and run all the jobs scheduled for that second. If the current list has jobs that are scheduled to run in the future, they are left back to be executed later:

(define (scheduler)
  (sleep 1)
  (run-jobs (current-seconds))
  (scheduler))

(define (run-jobs now)
  (let* ((index (remainder now max-jobs))
         (q (vector-ref jobs index)))
    (let loop ((old-q q) (new-q ()))
      (if (not (null? old-q))
          (let ((job (car old-q)))
            (if (run-job job now)
                (loop (cdr old-q) new-q)
                (loop (cdr old-q) (cons job new-q))))
          (vector-set! jobs index new-q)))))

 (define (run-job job now)
   (if (<= (job-run-at job) now)
       (begin
         (thread (job-proc job))
         #t)
       #f))

The scheduler runs in its own thread:

(define (run-scheduler)
  (thread scheduler))

A test run of the scheduler:

> (run-scheduler)
> (schedule-job 5 (lambda () (printf "group1 job1~n") (flush-output)))
> (schedule-job 5 (lambda () (printf "group1 job2~n") (flush-output)))
> (schedule-job 15 (lambda () (printf "group3 job1~n") (flush-output)))
> (schedule-job 10 (lambda () (printf "group2 job1~n") (flush-output)))
;; after 5 seconds:
group1 job1
group1 job2
;; after 10 seconds:
group2 job1
;; after 15 seconds:
group3 job1

Reference: The Design and Implementation of the FreeBSD Operating System.

Niue updates

Added two new words to Niue – ^ and get-r. ^ raises a number to the power of another:

4 2 ^ .
=> 16.0
673874883784677373 6 ^ .
=> 9364306491992936597418307443160066797807428695875
   3713230115132798366662566814067348891103643839017799209689

get-r is similar to get, but it removes the key-value mapping from the stack:

'x 10 'y 200
'x get-r .s
=> y 200 10

get-r can be used to emulate keyword arguments:

[ 'x get-r 'x ;
  'y get-r 'y ;

   x y / . ] 'd ;

'x 123.45 'y 34 d
=> 3.6308823529411764

( order of values on the stack does not matter. )
'y 34 'x 123.45 d
=> 3.6308823529411764

Also wrote a short tutorial that highlights the syntax-less nature of Niue.

An asynchronous network server

An event-based echo server in Spark-Scheme:

(define server (create-server
                   (lambda (client)
                      (socket-send client (recv-all client)))))

(listen server 8080)

This is built on top of the reactor framework:

(import (net) (reactor))

(define (create-server on-client-request)
   (let ((server-socket (socket-acceptor)))
     (acceptor-on-client-read! server-socket
          (lambda (acceptor client-socket)
             (socket-non-blocking! client-socket #t)
             (on-client-request client-socket)))
     (acceptor-on-server-timeout! server-socket
         (lambda (acceptor) null))
     (acceptor-on-client-connect! server-socket
          (lambda (acceptor client-socket)
             (acceptor-add-watch acceptor 
                   (connection-socket client-socket) 'for-read)))
     server-socket))

(define (listen server-socket port)
   (acceptor-port! server-socket port)
   (acceptor-open server-socket #t (list 10 0))
   (let ((cb null))
     (set! cb (lambda () (acceptor-watch server-socket) (cb)))
     (thread cb)))

(define (recv-all socket)
   (let loop ((in (socket-recv socket 1024))
              (s (open-output-string)))
     (if (> (string-length in) 0)
       (begin
          (fprintf s "~a" in)
          (loop (socket-recv socket 1024) s))
       (get-output-string s))))

A client written in python to test the server:

import socket
import sys

HOST = '127.0.0.1'
PORT = 8080

try:
  sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
except socket.error, msg:
  sys.stderr.write("[ERROR] %s\n" % msg[1])
  sys.exit(1)

try:
  sock.connect((HOST, PORT))
except socket.error, msg:
  sys.stderr.write("[ERROR] %s\n" % msg[1])
  sys.exit(2)

req = ""
req = req + sys.argv[1]
req = req + "\n"

sock.send(req)
string = sock.recv(len(req))
print len(string)
sock.close()

Though it need some tidying-up, the reactor framework can be used to write interesting network applications.

kth order statistic

A worst-case O(n) algorithm to find the kth largest element in a list:

(define (quickselect alist k)
 ;; Divide the list into two:
 ;; elements greater and lesser than
 ;; the median.
(let* ((x (pick-mid alist))
       (lt (lesser x alist))
       (gt (greater x alist))
       (gt-len (length gt)))
 (cond ((<= k gt-len)
           ;; kth largest must be in gt
           (quickselect gt k))
          ((> k (+ gt-len 1))
           (quickselect lt (- k gt-len 1)))
         (else x))))

A sample run:

(define a '(10 3 5 8 20 90))
(printf "~a~n" (quickselect a 5)) ;; => 5
(printf "~a~n" (quickselect a 1)) ;; => 90
(printf "~a~n" (quickselect a 4)) ;; => 8
(printf "~a~n" (quickselect a 3)) ;; => 10
(printf "~a~n" (quickselect a 2)) ;; => 20

The helper functions used by quickselect:

(define (lesser x alist)
  (filter (lambda (a) (< a x)) alist))

(define (greater x alist)
  (filter (lambda (a) (> a x)) alist))

(define (pick-mid alist)
  (list-ref alist (round (/ (length alist) 2))))

Speeding up Fibonacci

The following definition of the Fibonacci function is found in almost all introductory programming texts that teach recursion:

(define (fib N)
  (if (or (= N 0) (= N 1))
      1
    (+ (fib (- N 1)) (fib (- N 2)))))

It works fine for very small values of N. But the algorithm starts to show its inefficiency as the value of N gets larger. An attempt to profile (fib 40) in Racket produced the following output:

(time (fib 40))


cpu time: 60763 real time: 61093 gc time: 0
165580141

With inputs like 29, 30 or 40, the function has to make millions of recursive calls. Usually authors just ignore this inefficiency. Lawrence C. Paulson might be an exception. In his book, ML for the Working Programmer, he shows how mathematical induction could be used to optimize this function. His algorithm is simple and is based on the following reasoning:

Each Fibonacci number is the sum of the previous two:

0 + 1 = 1, 1 + 1 = 2, 1 + 2 = 3, 2 + 3 = 5,  3 + 5 = 8 ...

It is easy to define a function that takes a pair of numbers and return their sum:

(define (sum pair) (+ (car pair) (cdr pair)))

Let us define a function that returns a pair that contain the last element of the input along with the sum so that recursively calling it will reproduce the above pattern:

(define (nextfib pair) (cons (cdr pair) (sum pair)))

> (nextfib (cons 0 1))
(1 . 1)
> (nextfib (cons 1 1))
(1 . 2)
> (nextfib (cons 1 2))
(2 . 3)
> (nextfib (cons 2 3))
(3 . 5)
> (nextfib (cons 3 5))
(5 . 8)

To compute the Nth element we just recursively call nextfib N times:

(define (fib n)
  (if (= n 0)
      (cons 0 1)
    (nextfib (fib (- n 1)))))

> (time (fib 40))
cpu time: 0 real time: 1 gc time: 0
(102334155 . 165580141)
> (time (fib 400))
cpu time: 0 real time: 0 gc time: 0
(176023680645013966468226945392411250770384383304492191886725992896575345044216019675
 .
284812298108489611757988937681460995615380088782304890986477195645969271404032323901)

The profiling results show that we indeed have a better performing fibonacci procedure! It is also possible to improve the space efficiency of nextfib if we take advantage of tail call optimization:

(define (nextfib n pair)
  (if (= n 0)
    pair
  (nextfib (- n 1) (cons (cdr pair) (sum pair)))))

(define (fib n)
  (nextfib n (cons 0 1)))

> (time (fib 40))
cpu time: 0 real time: 0 gc time: 0
(102334155 . 165580141)
> (time (fib 400))
cpu time: 0 real time: 0 gc time: 0
(176023680645013966468226945392411250770384383304492191886725992896575345044216019675
 .
284812298108489611757988937681460995615380088782304890986477195645969271404032323901)

Crazy sort

Want to twist your brain by sorting in a stack language? Ok. First we need to define a function to put the minimum value on top:

[ dup 'm ; [ at dup m < [ 'm ; ] if [ , ] else ] len 1 - times m ] 
'min ;

Next we need a secondary stack to hold the intermediate sorted values. Let us create a child virtual machine to keep track of the secondary stack, so that it can respond to a get message and push the sorted values back to the main stack:

{ >> dup 'get equals [ <<< ] when } 
'sorted ;

We now have a function to find the minimum value on the stack and a virtual machine to keep track of the sorted elements, implementing the simple selection sort algorithm is just another one-liner:

[ [ , min dup sorted remove ] len 1 - times 'get sorted reverse , ]

'selsort ;

So there is our “stack sorter” in three lines!

Tests:

4 2 3 1 6 7 selsort .s
=> 1 2 3 5 6 7
20 100 45 selsort .s
=> 20 45 100 
1 2 3 4 5 selsort .s
=> 1 2 3 4 5

A simple finite automaton

A finite automaton that recognizes the regular language of all strings (made of 0’s and 1’s) that contain the string 001 as a substring. For example, 001, 1001 and 1111001001 are valid in the language, but 11 and 010 are not.

(define (one? x)
  (= x 1))

;; State that skips all 1's.
;; When a 0 is encountered, state changes to q0.
(define (q x)
  (if (one? x)
      q
      q0))

;; If the pattern 00 is seen, moves to state q00.
;; Goes back to q if x = 1.
(define (q0 x)
  (if (one? x)
      q
      q00))

;; State is in the pattern 00.
;; If 1 is seen, move to the end state (e).
;; Otherwise, move back to q0.
(define (q00 x)
   (if (one? x)
       e
       q00))

;; Notifies the state machine that the pattern has been found.
(define (e)
  #t)

;; The state machine itself.
(define (m string)
  (let ((state q))
    (call/ec
      (lambda (k)
        (for x in string
            (set! state (state x))
            (if (eq? state e)
                (k (state))))
       #f))))

Tests:

> (m '(1 1 0 1 0))
#f
> (m '(1 1 0 0 1 0))
#t
> (m '(0 0 1))
#t
> (m '(1 1 1 1 1 1 1 0 0 1 1 1 1 1))
#t