#!/usr/local/bin/guile -s
!#

;;    Copyright (C) 2000,2003  Martin C Rodgers
;;
;;    This program is free software; you can redistribute it and/or modify
;;    it under the terms of the GNU General Public License as published by
;;    the Free Software Foundation; either version 2 of the License, or
;;    (at your option) any later version.
;;
;;    This program is distributed in the hope that it will be useful,
;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;    GNU General Public License for more details.
;;
;;    You should have received a copy of the GNU General Public License
;;    along with this program; if not, write to the Free Software
;;    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(use-modules
    (srfi srfi-1)
    (ice-9 syncase)
    (ice-9 optargs))

; 2/12/2000
(define* ((uncurry p) . l)
    (if (pair? l)
	(fold (lambda (a b)
		  (if (procedure? b)
		      (b a)
		      (error "can't uncurry with " b)))
	    p l)
	(error "should never be uncurried: " p l)))

(define-syntax curried-lambda
    (syntax-rules ()
	((curried-lambda () e ...)
	    (begin e ...))
	((curried-lambda (formal . formals) e ...)
	    (uncurry
		(lambda (formal)
		    (curried-lambda formals e ...))))))

(define-syntax define-curried
    (syntax-rules ()
        ((define-curried (name . formals) e ...)
	    (define name
		(curried-lambda formals e ...)))))


(define-curried (i p) p)
(define-curried (k p q) p)
(define-curried (b p q r) (p (q r)))
(define-curried (c p q r) (p r q))
(define-curried (s p q r) (p r (q r)))
(define-curried (w p q) (p q q))

;(define a (b (s i) (s i i)))
;(define (y f) (a a f))

(define* (((d f) b) x)
    ((f (b b)) x))

(define (y f)
    ((d f) (d f)))

(define kons (b c (c i)))
(define kar (c i k))
(define kdr (c i (k i)))

(define true k)
(define false (k i))
(define-curried (iif f p q) (f p q))
(define cnot (c (c i (k i)) k))
(define-curried (cand p q) (iif p q false))
(define-curried (cor p q) (iif p true q))

;;; tests

(define-syntax print
    (syntax-rules ()
        ((print e)
            (format #t "~a: ~a~%" 'e e))
        ((print e1 e2 ...)
            (begin
                (format #t "~a: ~a, " 'e1 e1)
                (print e2 ...)))))

(print (i 5))
(print ((k 5) 4))
(print (k 5 4))

(print (kar (kdr (kons 1 (kons 2 '())))))

(print (iif true 1 2))
(print (iif false 1 2))
(print (iif (cnot false) 1 2))
(print (iif (cand true false) 1 2))
(print (iif (cand true true) 1 2))
(print (iif (cand false false) 1 2))
(print (iif (cor true false) 1 2))
(print (iif (cor true true) 1 2))
(print (iif (cor false false) 1 2))

(define fact
    (y (curried-lambda (f n)
	   (if (= n 0)
	       1
	       (* n (f (- n 1)))))))

(define len
    (y (curried-lambda (f l)
	   (if (null? l)
	       0
	       (+ 1 (f (cdr l)))))))

(print (fact 4))
(print (len (list 1 2 3)))