No dice.

It seems like there ought to be a simple way to generalize something here, but I’ve been awake for over 24 hours and if I drink more coffee I’ll never get to sleep before tomorrow’s shift. Shit.

Least I have something to look forward to tomorr… tonight.

More dicking around. Stack friendly map.


(define (map func lst)
(if (null? lst) lst
(let ((newlis (list (func (first lst)))))
(let loop ((cur newlis) (lst (rest lst)))
(if (null? lst) newlis
(begin (set-cdr! cur (list (func (first lst))))
(loop (rest cur) (rest lst))))))))


Was trying to implement map with left fold. Wound up with this. The right fold implemention easily blows the stack in guile 1.8. Scheme48 copes perfectly well… with no perceptible difference in speed (which was basically instant) even with a 20k element list. Nice.

This works in both, though. I still have an hour to kill… hmm.

Late nights stuck at work on the weekends.

Fold gives me a hard on now. I’ll have to play with it more after some coffee. Think I’ll check out the reference implementation for SRFI 1, it looks like some sexy shit.


;;; Following along with:
; A tutorial on the universality and
; expressiveness of fold
; GRAHAM HUTTON
; University of Nottingham, Nottingham, UK
; http://www.cs.nott.ac.uk/-gmh
; J. Functional Programming 9 (4): 355–372, July 1999.
; Retreived from http://www.cs.nott.ac.uk/~gmh/fold.pdf

;; I use these at random.
(define first car)
(define second cadr)
(define head car)
(define tail cdr)
(define rest cdr)

;; fold, sum, product
;; Pg. 356(Journal)/2(PDF)
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (fold func base lst)
; (if (null? lst)
; base
; (func (first lst) (fold func base (rest lst)))))
(let loop ((lst lst))
(if (null? lst)
base
(func (first lst) (loop (rest lst))))))

(define (sum lst)
;; Pg 13 recommends foldl, iterative.
(fold + 0 lst))

(define (product lst)
(fold * 1 lst))

;; Pg. 3
;; length, append, reverse, map, filter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; fold (:) ys
(define (append hd tl)
;; This will share the tail.
;; (fold cons (fold cons tl '()) hd)) wouldn't,
;; but would still share (any (nested) lists).
(fold cons tl hd))

;; fold (λx n → 1 + n) 0
(define (length lst)
;; Remember that conceptually, fold is
;; (f (first lst) (fold f v (rest lst)))
;; so (length '(a b c)) basically becomes
;; (+ 1 (+ 1 (+ 1 0)))
(fold (lambda (hd tl) (+ 1 tl)) 0 lst))

;; fold (λx xs → xs + [x]) []
(define (reverse lst)
;; XXX This is shit.
; (fold (lambda (hd tl) (append tl (list hd))) (list) lst))
;; Improved, pg. 13.
;; foldl (λxs x → x : xs) []
(foldl (lambda (hd tl) (cons tl hd)) (list) lst))

;; fold (λx xs → f x : xs) []
(define (map func lst)
;; (map +1 '(1 2))
;; (cons (+1 1) (cons (+1 2) '()))
(fold (lambda (hd tl) (cons (func hd) tl)) (list) lst))

;; fold (λx xs → if p x then x : xs else xs) []
(define (filter pred? lst)
;; Haskell's syntax becomes appealing.
(fold (lambda (hd tl)
(if (pred? hd)
(cons hd tl)
tl))
(list)
lst))

;; Pg. 8
;; Sumlength
;;;;;;;;;;;;

;; fold (λn (x, y) → (n + x, 1 + y)) (0, 0)
(define (sumlength lst-of-nums)
; (fold (lambda (hd pair)
; (cons (+ hd (first pair))
; (+ 1 (second pair))))
; (cons 0 0)
; lst-of-nums))
;; Spew less interim garbage.
(fold (lambda (hd pair)
(set-car! pair (+ hd (first pair)))
(set-cdr! pair (+ 1 (rest pair)))
pair)
(cons 0 0)
lst-of-nums))

;; Pg 11.
;; compose
;;;;;;;;;;;;;;

;; fold (·) id
(define (compose lst)
(fold (lambda (fun1 fun2) ; dot
(lambda (x)
(fun1 (fun2 x))))
(lambda (x) x) ; id
lst))

;; Pg. 13
;; foldl
;;;;;;;;;

;; foldl f (f v x) xs
(define (foldl fun start lst)
; (if (null? lst)
; start
; (foldl fun
; (fun start (first lst))
; (rest lst))))
;; Don't keep passing fun around.
(let loop ((result start) (lst lst))
(if (null? lst)
result
(loop (fun result (first lst))
(rest lst)))))

(define (tst name result)
(if (not result)
(begin (display name)
(newline))))

(tst 'sum (= 15 (sum '(1 2 3 4 0 5))))
(tst 'rev (equal? '(baz (bar) foo)
(reverse '(foo (bar) baz))))
(tst 'app (equal? '(foo bar baz)
(append '(foo bar) '(baz))))
(tst 'len (= 3 (length '(a b c))))
(tst 'len (= 2 (length '(a '(b c)))))
(tst 'map (equal? '(1 2 3 4 5)
(map (lambda (x) (+ 1 x))
'(0 1 2 3 4))))
(tst 'filt (equal? '(2 4 6)
(filter even? '(1 2 3 3 5 7 4 599 99 6))))
(tst 'sumlen (equal? (cons 20 4) (sumlength '(2 4 6 8))))