(loadt "ba.adt")

(define (push d n)
  (if (zero? n)
      (_sim-error 'push "push out of range")
      (let ((next (- n 1)))
	(if (= d next)
	    next
	    (push d next)))))

(define (DC1 d) (cyclic 1 d 0))
(define (CD1 c)
  (caseconstr c ((cyclic b q r) q)))

(define (D->C d b)
  (let ((r (modulo d b))
	(q (divide d b)))
    (cyclic b q (push r b))))

(define (set-base c b^)
  (caseconstr c
    ((cyclic b q r)
     (if (= b b^) c
	 (let ((j (lcm b b^)))
	   (if (= b^ j)
	       (let ((e (divide b^ b)))
		 (cyclic b^
			 (divide q e)
			 (+ (* b (push (modulo q e) e))
			    r)))
	       (let* ((e (divide j b^))
		      (b^^ (divide b e)))
		 (set-base (cyclic b^^
				   (+ (divide r b^^)
				      (lift (* q e)))
				   (modulo r b^^))
			   b^))))))))

(define (+c c s)
  (caseconstr c
    ((cyclic b q r)
     (let ((r1 (modulo (+ r s) b))
	   (q1 (divide (+ r s) b)))
       (cyclic b (+ q q1) r1)))))

(define (zero?c c t f)
  (caseconstr c
    ((cyclic b q r)
     '(if (zero? (modulo r b))
	 (_sim-memoize (if (zero? q) (t) (f)))
	 (f))
     (if (zero? (modulo r b))
	 (if (zero? q) (_sim-memoize (t)) (_sim-memoize (f)))
	 (f)))))

(define (count c r)
  (zero?c c
	  (lambda () r)
	  (lambda () (count (+c c -1)
			    (+ r 7)))))

(define (count2 c r)
  (=c c (cyclic 4 (lift 0) 0)
      (lambda () r)
      (lambda () (count2 (+c c -1)
			 (+ r 7)))))

(define (count3 f t r)
    (=c f t
      (lambda () r)
      (lambda () (count3 (+c f 8) t (+ r 7)))))

(define (nested-count c r)
  (zero?c c
	  (lambda () r)
	  (lambda () (nested-count (+c c -1)
				   (+ r (count c (lift 0)))))))

(define (=c c0 c1 t f)
  (caseconstr c0
    ((cyclic b0 q0 r0)
     (caseconstr c1
       ((cyclic b1 q1 r1)
	(if (= b0 b1)
	    (if (= r0 r1)
		(_sim-memoize (if (= q0 q1) (t) (f)))
		(f))
	    (_sim-error '=c "bases differ: ~S ~S" b0 b1)))))))

; types of t and f are () -> signal instead of () -> D as above

(define (/c c s)
  (caseconstr c
    ((cyclic b q r)
     (if (zero? (modulo b s))
	 (cyclic (quotient b s) q (quotient r s))
	 (_sim-error '/c "uneven ~S ~S" b s)))))

(define (%c c s)
  (caseconstr c
    ((cyclic b q r)
     (if (= b s) r
	 (_sim-error '%c "uneven ~S ~S" b s)))))

;-------------

(define (mask b) (- (<< 1 b) 1))

(define (load-sample p b)
  (let* ((W 32)
	 (wa (/c p W))
	 (ba (%c p W))
	 (w0 (load-word wa)))
    (if (<= (+ b ba) W)
	(& (mask b) (>> w0 ba))
	(let* ((under-by (- W ba))
	       (s0 (& (mask under-by) (>> w0 ba)))
	       (w1 (load-word (/c (+c p under-by) W)))
	       (s1 (& w1 (mask (- b under-by)))))
	  (| s0 (<< s1 under-by))))))

(define (sum start stop size stride rez)
  (=c start stop
      (lambda () rez)
      (lambda () (sum (+c start stride) stop size stride
		      (+ rez (load-sample start size))))))

(define (sum-entry s0 s1 d0 d1)
  (sum (cyclic 32 d0 s0)
       (cyclic 32 d1 s1)
       8 8 (lift 0)))

(define (sum-entry2 s d d1)
  (let* ((y0 (cyclic 8 d1 0))
	 (b0 (set-base y0 32)))
    (sum (cyclic 32 d 0) b0 8 8 (lift 0)) ; lose
    ; (sum b0 (cyclic 32 d 0) 8 8 (lift 0)) ; win
    ))

(define (sum-entry2a s d d1)
  (let* ((y0 (cyclic 8 d1 0))
	 (b0 (set-base y0 32)))
    (sum b0 (cyclic 32 d s) 8 8 (lift 0))))

(define (sum-entry3 d0 d1)
  (let ((b0 (cyclic 8 d0 0))
	(b1 (cyclic 8 d1 0)))
    (sum (set-base b0 32)
	 (set-base b1 32)
	 8 8 (lift 0))))

; --------

(define (get s)
  (caseconstr s
   ((memory-signal start stop size stride)
    (load-sample start size))
   ((constant-signal c) c)
   ((delay-signal v s) v)
   ((prefix-signal v s) v)
   ((prefix-list-signal hd tl s) hd)
   ((append-signal hd tl s1) hd)
   ((map-signal f s) (f (get s)))
   ((binop-signal f s0 s1)
    (f (get s0) (get s1)))))

(define (end? s t f)
  (caseconstr s
   ((memory-signal start stop size stride)
    (=c start stop t f))
   ((constant-signal c) (t))
   ((delay-signal v s) (end? s t f))
   ((prefix-signal v s) (f))
   ((prefix-list-signal hd tl s) (f))
   ((append-signal hd tl s1) (f))
   ((map-signal op s) (end? s t f))
   ((binop-signal op s0 s1)
    (end? s0 (lambda () (end? s1 t f)) f)))) ; duplication

(define (next s)
  (caseconstr s
   ((memory-signal start stop size stride)
    (memory-signal (+c start stride) stop size stride))
   ((constant-signal c) s)
   ((delay-signal v s) (delay-signal (get s) (next s)))
   ((prefix-signal v s) s)
   ((prefix-list-signal hd tl s)
    (if (null? tl) s (prefix-list-signal (car tl) (cdr tl) s)))
   ((map-signal f s) (map-signal f (next s)))
   #| ((append-signal hd tl s1)
    (end? tl
	  (lambda () s1)
	  (lambda ()
	    (append-signal (get tl) (next tl) s1)))) |#
   ((binop-signal f s0 s1)
    (binop-signal f (next s0) (next s1)))))

(define (plus x y) (+ x y))
(define (times x y) (* x y))

(define (reduce s r f)
  (end? s
	(lambda () r)
	(lambda () (reduce (next s) (f r (get s)) f))))


(define (reduce-entry2 d0 d1)
  (get (next (delay-signal 0 (constant-signal 8)))))

(define (reduce-entry3 d0 d1)
  (reduce (binop-signal >>
			(memory-signal (cyclic 32 d0 0)
				       (cyclic 32 d1 0)
				       8 8)
			(constant-signal 8))
	  (lift 0) plus))

(define (filter prefix kernel in)
  (if (null? prefix)
      (constant-signal 0)
      (binop-signal plus
		    (map-signal (lambda (v) (* (car kernel) v)) in)
		    (filter (cdr prefix) (cdr kernel)
			    (delay-signal (car prefix) in)))))

(define (reduce-entry5 d0 d1)
  (reduce (filter '(0 0) '(1 2)
		  (memory-signal (cyclic 32 d0 0)
				 (cyclic 32 d1 0)
				 8 8))
	  (lift 0) plus))

(define (reduce-entry6 d0 d1)
  (reduce (filter '(0 0 0 0 0) '(1 2 4 2 1)
		  (memory-signal (cyclic 32 d0 0)
				 (cyclic 32 d1 0)
				 32 32))
	  (lift 0) plus))

(define (reduce-entry7 d0 d1)
  (reduce (prefix-signal 99 (memory-signal (cyclic 32 d0 0)
					   (cyclic 32 d1 0)
					   8 8))
	  (lift 0) plus))

(define (reduce-entry8 d0 d1)
  (reduce (prefix-list-signal 2 '(3 5 7 11)
			      (memory-signal (cyclic 32 d0 0)
					   (cyclic 32 d1 0)
					   8 8))
	  (lift 0) plus))

(define (set-base-entry s d)
  (caseconstr (set-base (cyclic s d 0) 6)
    ((cyclic b q r)
     (list b q r))))

(define (count-entry s d)
  (count (cyclic s d 0) (lift 0)))

(define (unl-entry d)
  (+ 10 (push d 4)))

(define (count-entry3 d)
  (count (D->C d 4) (lift 0)))

(define (count2-entry s d)
  (count2 (D->C d 4) (lift 0)))

(define (count3-entry d0 d1)
  (let* ((p0 (set-base (cyclic 8 d0 0) 32))
	 (p1 (set-base (cyclic 8 d1 0) 32))
	 (evend (+c p1 (- (%c p1 32))))
	 (i0 (lift 0))
	 (i1 (count3 p0 evend i0))
	 )
    ; (caseconstr evend ((cyclic b q r) (debug (list b q r))))
     (count3 evend p1 i1)
    ))

(define (count3-entry2 d0 d1)
  (let* ((y0 (cyclic 8 d0 0))
	 (y1 (cyclic 8 d1 0))
	 
	 (p0 (set-base y0 32))
	 (evend (cyclic 32 (divide d0 4) 0))
	 (i0 (lift 0))
	 (i1 (count3 p0 evend i0))
	 )
    ; (caseconstr evend ((cyclic b q r) (debug (list b q r))))
    (count3 evend (set-base y1 32) i1)
    ; i1
    ))

(define (nested-count-entry s d)
  (nested-count (cyclic s d 0) (lift 0)))


(define (reduce-entry d0 d1)
  (reduce (memory-signal (cyclic 32 d0 0)
			 (cyclic 32 d1 0)
			 16 16)
	  (lift 0) plus))





(define (reduce-entry4 d0 d1)
  (reduce (delay-signal 10
			(memory-signal (cyclic 32 d0 0)
				       (cyclic 32 d1 0)
				       8 8))
	  (lift 0) plus))

(define (reduce-entry4b d0 d1)
  (reduce (map-signal (lambda (v) (* 10 v))
		      (memory-signal (cyclic 32 d0 0)
				     (cyclic 32 d1 0)
				     8 8))
	  (lift 0) plus))

(define (reduce-entry4c d0 d1)
  (let ((s (memory-signal (cyclic 32 d0 0)
			  (cyclic 32 d1 0)
			  8 8)))
    (reduce (binop-signal plus s (delay-signal 10 s))
	    (lift 0) plus)))