corectl

 1(import scheme (chicken base) (srfi 1) corectl)
 2
 3(define (range upto)
 4  (if (zero? upto)
 5    '()
 6    (let ((i (- upto 1)))
 7      (append (range i) (list i)))))
 8
 9(define (ntimes n proc)
10  (define (%ntimes i proc)
11    (when (< i n)
12      (proc i)
13      (%ntimes (+ i 1) proc)))
14
15  (%ntimes 0 proc))
16
17(define (led-list defval)
18  (fold (lambda (x y)
19          (append y (list (cons x defval))))
20        '() (range num-leds)))
21
22(define off-all (led-list 'off))
23(define restore-all (led-list 'restore))
24
25(define (led-pattern ctl)
26  (ntimes num-leds
27          (lambda (i)
28            (let ((asc (fold (lambda (x y)
29                               (cons
30                                 (cons
31                                   x
32                                   (cond
33                                     ((>= i x) 'on)
34                                     (else     'off))) y)) '() (range num-leds))))
35              (led-ctl-write ctl asc)
36              (sleep 2)))))
37
38(define (main)
39  (let ((ctrl (make-led-ctl)))
40    (call-with-led-ctl
41      ctrl
42      (lambda (c)
43        (led-ctl-write c off-all)
44        (sleep 1)
45        (led-pattern c)
46        (sleep 1)
47        (led-ctl-write c restore-all)))))
48
49(cond-expand
50  ((or chicken-script compiling) (main))
51  (else #t))