;;; -*- Mode: LISP -*-

(herald fib)
(define-local-syntax (future x) x)
(define (fib n)
	(if (fx< n 2)
	    n
	    (fx+ (future (fib (fx- n 1))) (future (fib (fx- n 2))))))

(define (main)  (fib 22))
;;; -*- Mode: LISP -*-

(herald fib)
;(define-local-syntax (future x) x)
(define (fib n)
	(if (fx< n 2)
	    n
	    (fx+ (future (fib (fx- n 1))) (future (fib (fx- n 2))))))

(define (main)  (fib 22))
(herald factor (env tsys))

;;;; for sequential code:
(define-local-syntax (future x) x)

;;;;
;; factor.t
;; kirk johnson
;; october 1989
;;
;; prime factorization stuff
;;;;


;;;; (define-constant fx* fixnum-multiply)
;;;; (define-constant fx/ fixnum-divide)


(define (main)
  (map-and-combine-interval largest-prime-factor sum 1 5000))


(define (largest-prime-factor n)
  (last (prime-factors n)))


(define (prime-factors n)
  (iterate loop ((idx 2))
    (cond ((too-big? idx n)
	   (cons n '()))
	  ((divides? idx n)
	   (cons idx
		 (prime-factors (fx/ n idx))))
	  (else
	   (loop (fx+ idx 1))))))


(define (too-big? idx n)
  (fx> (fx* idx idx) n))


(define (divides? idx n)
  (fx= (fixnum-remainder n idx) 0))


(define (map-and-combine-interval proc combiner lo hi)
  (if (fx= lo hi)
      (proc lo)
      (let* ((mid-lo (fx/ (fx+ lo hi) 2))
	     (mid-hi (fx+ mid-lo 1)))
	(combiner
	 (future
	  (map-and-combine-interval proc combiner lo mid-lo))
	 (future
	  (map-and-combine-interval proc combiner mid-hi hi))))))


(define (last lst)
  (iterate loop ((rslt (car lst))
		 (rest (cdr lst)))
    (if (null? rest)
	rslt
	(loop (car rest) (cdr rest)))))


(define (sum a b)
  (fx+ a b))
(herald factor (env tsys))

;;;; for sequential code:
;(define-local-syntax (future x) x)

;;;;
;; factor.t
;; kirk johnson
;; october 1989
;;
;; prime factorization stuff
;;;;


;;;; (define-constant fx* fixnum-multiply)
;;;; (define-constant fx/ fixnum-divide)


(define (main)
  (map-and-combine-interval largest-prime-factor sum 1 5000))


(define (largest-prime-factor n)
  (last (prime-factors n)))


(define (prime-factors n)
  (iterate loop ((idx 2))
    (cond ((too-big? idx n)
	   (cons n '()))
	  ((divides? idx n)
	   (cons idx
		 (prime-factors (fx/ n idx))))
	  (else
	   (loop (fx+ idx 1))))))


(define (too-big? idx n)
  (fx> (fx* idx idx) n))


(define (divides? idx n)
  (fx= (fixnum-remainder n idx) 0))


(define (map-and-combine-interval proc combiner lo hi)
  (if (fx= lo hi)
      (proc lo)
      (let* ((mid-lo (fx/ (fx+ lo hi) 2))
	     (mid-hi (fx+ mid-lo 1)))
	(combiner
	 (future
	  (map-and-combine-interval proc combiner lo mid-lo))
	 (future
	  (map-and-combine-interval proc combiner mid-hi hi))))))


(define (last lst)
  (iterate loop ((rslt (car lst))
		 (rest (cdr lst)))
    (if (null? rest)
	rslt
	(loop (car rest) (cdr rest)))))


(define (sum a b)
  (fx+ a b))
(herald queens)

;;;; Builds a list of all solutions; no containment
;;;; No pooling 

;;; ----------------------------------------------------------------------------
(define-local-syntax (future x) x)

(define (queens board-size)
  (init-constants board-size)
  (iterate row-loop ((row 0)
                     (board (empty-board))
                     (solutions '()))
    (cond ((fx= row board-size)
           (cons board solutions))
          (else
           (iterate col-loop ((col 0))
             (cond ((fx= col board-size)
                    solutions)
                   ((legal-move? board row col)
                    (let ((newboard (update-board board row col))
			   (newsols solutions))
		      (set
                           solutions
                             (future (row-loop (fx+ row 1) newboard newsols)))
                      (col-loop (fx+ col 1) )))
                   (else 
                    (col-loop (fx+ col 1) ))))))))


(define (main)
  (check-answer 10 (length (queens 10))))
#|
(define (seq)
  (timer 3 '(1)
    (QUEENS   () (length (queens 10))  (lambda (a) (check-answer 10 a)))
    (BQUEENS  () (length (bqueens 10)) (lambda (a) (check-answer 10 a)))))

(define (rt n)
  (timer 3 '(1 2 4 8)
    (PQUEENS () (length (pqueens n)) (lambda (a) (check-answer n a)))))
|#
;;; ----------------------------------------------------------------------------
;;; make sure no mistakes

#|
(define (answers)
  (dotimes (i 20)
    (format t "~-4d~-8d~%" i (bqueens i))))
|#

(define the-answers '#(1 1 0 0 2 10 4 40 92 352 724 2680 14200 73712))

(define (check-answer n answer)
  (let ((the-answer (vref the-answers n)))
    (if (not (fx= answer the-answer))
        (error "Wrong answer for n = ~d; expected ~d but got ~d~%"
               n the-answer answer)
        '#t)))

;;; ----------------------------------------------------------------------------
;;; the board

(lset *board-size* 0)
(lset *ndiagonals* 0)
(lset *2ndiagonals* 0)
(lset *nboardwords* 0)
(lset *nboardbytes* 0)
(lset *nsolutions* 0)

(define (init-constants board-size)
  (set *board-size* board-size)
  (set *ndiagonals* (fx- (fx* 2 board-size) 1))
  (set *2ndiagonals* (fx* 2 *ndiagonals*))
  (let* ((nflags (fx+ board-size *2ndiagonals*))
         (nflags4 (fx/ (fx+ nflags 3) 4)))
    (set *nboardwords* nflags4)
    (set *nboardbytes* (fx* nflags4 4)))
  (set *nsolutions* 0))

(define-constant (empty-board) (make-vector *nboardbytes*))

(define-constant (copy-board oldboard)
	(copy-vector oldboard))

(define-constant (legal-move? board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (and (column-free? board col)
         (diag\\-free? board diag\\)
         (diag//-free? board diag//))))

(define-constant (update-board oldboard row col)
  (let ((newboard (copy-board oldboard))
        (diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (mark-column newboard col)
    (mark-diag\\ newboard diag\\)
    (mark-diag// newboard diag//)
    newboard))

(define-constant (update-board! board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (mark-column board col)
    (mark-diag\\ board diag\\)
    (mark-diag// board diag//)
    board))

(define-constant (un-update-board! board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (clear-column board col)
    (clear-diag\\ board diag\\)
    (clear-diag// board diag//)
    board))

(define-constant (mark-column board col)    (set (vref board col) 1))
(define-constant (mark-diag// board diag//) (set (vref board (fx+ diag// *board-size*)) 1))
(define-constant (mark-diag\\ board diag\\) (set (vref board (fx+ diag\\ *2ndiagonals*)) 1))
  
(define-constant (clear-column board col)    (set (vref board col) 0))
(define-constant (clear-diag// board diag//) (set (vref board (fx+ diag// *board-size*)) 0))
(define-constant (clear-diag\\ board diag\\) (set (vref board (fx+ diag\\ *2ndiagonals*)) 0))
  
(define-constant (column-free? board col)    (fx-zero? (vref board col)))
(define-constant (diag//-free? board diag//) (fx-zero? (vref board (fx+ diag// *board-size*))))
(define-constant (diag\\-free? board diag\\) (fx-zero? (vref board (fx+ diag\\ *2ndiagonals*))))
(herald queens)

;;;; Builds a list of all solutions; no containment
;;;; No pooling 

;;; ----------------------------------------------------------------------------
;(define-local-syntax (future x) x)

(define (queens board-size)
  (init-constants board-size)
  (iterate row-loop ((row 0)
                     (board (empty-board))
                     (solutions '()))
    (cond ((fx= row board-size)
           (cons board solutions))
          (else
           (iterate col-loop ((col 0))
             (cond ((fx= col board-size)
                    solutions)
                   ((legal-move? board row col)
                    (let ((newboard (update-board board row col))
			   (newsols solutions))
		      (set
                           solutions
                             (future (row-loop (fx+ row 1) newboard newsols)))
                      (col-loop (fx+ col 1) )))
                   (else 
                    (col-loop (fx+ col 1) ))))))))


(define (main)
  (check-answer 10 (length (queens 10))))
#|
(define (seq)
  (timer 3 '(1)
    (QUEENS   () (length (queens 10))  (lambda (a) (check-answer 10 a)))
    (BQUEENS  () (length (bqueens 10)) (lambda (a) (check-answer 10 a)))))

(define (rt n)
  (timer 3 '(1 2 4 8)
    (PQUEENS () (length (pqueens n)) (lambda (a) (check-answer n a)))))
|#
;;; ----------------------------------------------------------------------------
;;; make sure no mistakes

#|
(define (answers)
  (dotimes (i 20)
    (format t "~-4d~-8d~%" i (bqueens i))))
|#

(define the-answers '#(1 1 0 0 2 10 4 40 92 352 724 2680 14200 73712))

(define (check-answer n answer)
  (let ((the-answer (vref the-answers n)))
    (if (not (fx= answer the-answer))
        (error "Wrong answer for n = ~d; expected ~d but got ~d~%"
               n the-answer answer)
        '#t)))

;;; ----------------------------------------------------------------------------
;;; the board

(lset *board-size* 0)
(lset *ndiagonals* 0)
(lset *2ndiagonals* 0)
(lset *nboardwords* 0)
(lset *nboardbytes* 0)
(lset *nsolutions* 0)

(define (init-constants board-size)
  (set *board-size* board-size)
  (set *ndiagonals* (fx- (fx* 2 board-size) 1))
  (set *2ndiagonals* (fx* 2 *ndiagonals*))
  (let* ((nflags (fx+ board-size *2ndiagonals*))
         (nflags4 (fx/ (fx+ nflags 3) 4)))
    (set *nboardwords* nflags4)
    (set *nboardbytes* (fx* nflags4 4)))
  (set *nsolutions* 0))

(define-constant (empty-board) (make-vector *nboardbytes*))

(define-constant (copy-board oldboard)
	(copy-vector oldboard))

(define-constant (legal-move? board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (and (column-free? board col)
         (diag\\-free? board diag\\)
         (diag//-free? board diag//))))

(define-constant (update-board oldboard row col)
  (let ((newboard (copy-board oldboard))
        (diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (mark-column newboard col)
    (mark-diag\\ newboard diag\\)
    (mark-diag// newboard diag//)
    newboard))

(define-constant (update-board! board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (mark-column board col)
    (mark-diag\\ board diag\\)
    (mark-diag// board diag//)
    board))

(define-constant (un-update-board! board row col)
  (let ((diag\\ (fx- row col))
        (diag// (fx+ row col)))
    (clear-column board col)
    (clear-diag\\ board diag\\)
    (clear-diag// board diag//)
    board))

(define-constant (mark-column board col)    (set (vref board col) 1))
(define-constant (mark-diag// board diag//) (set (vref board (fx+ diag// *board-size*)) 1))
(define-constant (mark-diag\\ board diag\\) (set (vref board (fx+ diag\\ *2ndiagonals*)) 1))
  
(define-constant (clear-column board col)    (set (vref board col) 0))
(define-constant (clear-diag// board diag//) (set (vref board (fx+ diag// *board-size*)) 0))
(define-constant (clear-diag\\ board diag\\) (set (vref board (fx+ diag\\ *2ndiagonals*)) 0))
  
(define-constant (column-free? board col)    (fx-zero? (vref board col)))
(define-constant (diag//-free? board diag//) (fx-zero? (vref board (fx+ diag// *board-size*))))
(define-constant (diag\\-free? board diag\\) (fx-zero? (vref board (fx+ diag\\ *2ndiagonals*))))