; File "subject.ss" -- Various Scheme0 subject programs
; Partial evaluator for first order functional language
; 1992-05-01, 1995-08-11

; (load (in-vicinity (library-vicinity) "pp"))
(define pretty pretty-print)
(define (pretty-file val file) 
  (let ((port (open-output-file file)))
    (pretty-print val port)
    (close-output-port port)))

; The inefficient (linear) power function:

(define power-lin '
((define (pow n x) 
   (if (op equal? n 0)
       1
       (op * x (call pow (op - n 1) x)))))
)

; The efficient (logarithmic) power function:

(define power '
((define (pow n x)
    (if (op equal? n 0)
        1
        (if (op even? n)
            (call pow (op quotient n 2) (op * x x))
            (op * x (call pow (op - n 1) x))))))
)

(define swap '
   ((define (swap x y)
       (call swap y x))))

; A Norma2 interpreter (Bird 1976)

(define norma (desugar '(
(define (execute pgm x) (call run pgm pgm x '()))

(define (run pgm suf x y)
   (if (op null? suf) y
   (if (op equal? (hd suf) 'x:=x+1)
       (call run pgm (tl suf) (:: 1 x) y)
   (if (op equal? (hd suf) 'y:=y+1)
       (call run pgm (tl suf) x (:: 1 y))
   (if (op equal? (hd suf) 'x:=x-1)
       (call run pgm (tl suf) (tl x) y)
   (if (op equal? (hd suf) 'y:=y-1)
       (call run pgm (tl suf) x (tl y))
   (if (op equal? (hd (hd suf)) 'goto)
       (call run pgm (call hop pgm (tl (hd suf))) x y)
   (if (op equal? (hd (hd suf)) 'ifx=0)
       (if (op null? x)
           (call run pgm (call hop pgm (tl (hd suf))) x y)
           (call run pgm (tl suf) x y))
   (if (op equal? (hd (hd suf)) 'ify=0)
       (if (op null? y)
           (call run pgm (call hop pgm (tl (hd suf))) x y)
           (call run pgm (tl suf) x y))
       (call run pgm pgm y x)
)))))))))

(define (hop pgm dest)
   (if (op null? dest)
       pgm
       (call hop (tl pgm) (tl dest))
))
)))

; A Norma source program, doubling the input number (in monadic form):

(define twice '
   ((ifx=0 . (1 1 1 1 1))
    y:=y+1
    y:=y+1
    x:=x-1
    (goto . '())
))

; A naive string matcher (JGS Figure 12.1)
(define match1 (desugar '(
(define (match p d) (call loop p d p d))

(define (loop p d pp dd)
  (if (op null? p) 'yes
  (if (op null? d) 'no
  (if (op equal? (hd p) (hd d))
      (call loop (tl p) (tl d) pp dd)
      (call match pp (tl dd))))))
)))

(define (snoc xs x) 
  (if (null? xs) 
      (list x)
      (cons (car xs) (snoc (cdr xs) x))))

; Improved string matcher, positive info only (JGS Figure 12.2)
(define match2 (desugar '(

(define (match p d) (call loop p d p '() '()))

(define (loop p d pp f ff)
  (if (op null? p) 'yes
  (if (op null? f) 
      (if (op null? d) 'no
      (if (op equal? (hd p) (hd d)) 
	  (call loop (tl p) (tl d) pp '() (op snoc ff (hd p)))
      (if (op null? ff)
	  (call match pp (tl d))
	  (call loop pp d pp (tl ff) (tl ff)))))
  (if (op equal? (hd p) (hd f))
      (call loop (tl p) d pp (tl f) ff)
      (call loop pp d pp (tl ff) (tl ff))
)))))))

; Improved string matcher, using negative info (JGS Figure 12.3)
; Gives specialized matchers similar to Knuth-Morris-Pratt's

(define match3 (desugar '(

(define (match p d) (call loop p d p '() '() '()))

(define (loop p d pp f ff neg)
  (if (op null? p) 'yes
  (if (op null? f) 
      (if (op member (hd p) neg)
	  (if (op null? ff) 
	      (call match pp (tl d))
	      (call loop pp d pp (tl ff) (tl ff) neg))
      (if (if (op null? neg) (op null? d) #f) 'no
      (if (op equal? (hd p) (hd d)) 
	  (call loop (tl p) (tl d) pp '() (op snoc ff (hd p)) '())
      (if (op null? ff)
	  (call match pp (tl d))
	  (call loop pp d pp (tl ff) (tl ff) (op cons (hd p) neg))))))
  (if (op equal? (hd p) (hd f))
      (call loop (tl p) d pp (tl f) ff neg)
      (call loop pp d pp (tl ff) (tl ff) neg)
)))))))

(define pat1 '(a a a a a a a a a a a a a a a a a a b))

(define data1
  '(a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a
    a a a a a a a a a a a a a a a a a a a a a a a a a a a a b))

; Ackermann's function

(define ack '(
  (define (ack m n)
    (if (op equal? m 0) (op + n 1)
	(if (op equal? n 0)
	    (call ack (op - m 1) 1)
	    (call ack (op - m 1) (call ack m (op - n 1)))))
  )))