  berkeley.scm 4.03.01 Tue Jul 22 17:22:59 2003
;
  NOTE : THE MASTER COPY OF THIS FILE IS MAINTAINED BY EECS INSTRUCTIONAL
  SUPPORT . IF YOU MAKE CHANGES HERE THEY WILL GO AWAY .
;
  Compatibility library for UCB Scheme ( STk 4.0.1 derivative ) as used
  in CS61A and CS3 . Over - hauled in May 2000 and April 2003 for
;; STk compatibility and to remove dead code.
;;

(define nil '())
(define true #t)
(define false #f)

  4.0 :  already has a time program , so I nuked time
  4.0 : STk load already has glob built in , so I nuked redef . of load
;; 4.02.01: Remove definition of read.

;; Removed 

  SICP stuff :

(define (print x)
  (write x)
  (newline))

  Define tagged data ADT :

(define (attach-tag type-tag contents)
  (cons type-tag contents))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum)))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum -- CONTENTS" datum)))

For Section 3.1.2 -- written as suggested in footnote ,
;; though the values of a, b, m may not be very "appropriately chosen"
(define (rand-update x)
  (let ((a 27) (b 26) (m 127))
    (modulo (+ (* a x) b) m)))

For Section 3.3.4 , used by and - gate
;;Note: logical-and should test for valid signals, as logical-not does
(define (logical-and x y)
  (if (and (= x 1) (= y 1))
      1
      0))

;; concurrency stuff

  4.0 : Simplified these somewhat -- removed tests for scm
;;  and added alarm-signal-handler stuff

; For timer interrupts in STk:
(define (alarm-signal-handler sig) (alarm-interrupt))
(add-signal-handler! 14 alarm-signal-handler)

(require 'process)

(define test-and-set!
	     (let ((arb (make-arbiter 'scratchnsniff)))
	       (lambda (cell)
		 (if (try-arbiter arb)
		     (begin (process:schedule!)
			    (test-and-set! cell))
		     (let ((result (car cell)))
		       (set-car! cell #t)
		       (release-arbiter arb)
		       result)))))

(define (parallel-execute . thunks)
	     (for-each (lambda (thunk) (add-process! (lambda (foo) (thunk))))
		       thunks)
	     (alarm-interrupt)
	     (process:schedule!))

(define (stop) (alarm 0) (set! process:queue (make-queue)))

For Section 3.5.2 , to check power series ( exercises 3.59 - 3.62 )
;;Evaluate and accumulate n terms of the series s at the given x
Uses    from ex 2.34
(define (eval-power-series s x n)
  (horner-eval x (first-n-of-series s n)))
(define (first-n-of-series s n)
  (if (= n 0)
      '()
      (cons (stream-car s) (first-n-of-series (stream-cdr s) (- n 1)))))

;; Streams:
  4.0 : We do not redefine promises as procedures anymore .

; Restrict the domain of FORCE to include only promises.
(define force
  (let ((force force))
    (lambda (p)
      (if (not (promise? p))
          (error "Not a promise: " p)
          (force p)))))

(define-macro (cons-stream . args) 
              `(cons ,(car args) (delay ,(cadr args))))

(define (stream-car stream) (car stream))

(define (stream-cdr st)
  (force (cdr st)))

(define the-empty-stream '())

(define (stream-null? stream) (eq? stream the-empty-stream))

(define (stream? obj)
  (or (stream-null? obj)
      (and (pair? obj) (promise? (cdr obj)))))

(define (stream-accumulate combiner initial-value stream)
  (if (stream-null? stream)
      initial-value
      (combiner (stream-car stream)
		(stream-accumulate combiner
				   initial-value
				   (stream-cdr stream)))))

(define (accumulate-delayed combiner initial-value stream)
  (if (stream-null? stream)
      initial-value
      (combiner (stream-car stream)
                (delay
                 (accumulate-delayed combiner
                                     initial-value
                                     (stream-cdr stream))))))

(define (interleave s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1)
                   (interleave s2 (stream-cdr s1)))))

(define (interleave-delayed s1 delayed-s2)
  (if (stream-null? s1)
      (force delayed-s2)
      (cons-stream (stream-car s1)
                   (interleave-delayed (force delayed-s2)
                                       (delay (stream-cdr s1))))))

(define (stream-flatten stream)
  (accumulate-delayed interleave-delayed
                      the-empty-stream
                      stream))

(define (stream-ref s n)
  (if (= n 0)
      (stream-car s)
      (stream-ref (stream-cdr s) (- n 1))))

(define (stream-map proc . s)
  (if (stream-null? (car s))
      the-empty-stream
      (cons-stream (apply proc (map stream-car s))
                   (apply stream-map proc (map stream-cdr s)))))

(define (stream-for-each proc s)
  (if (stream-null? s)
      'done
      (begin
       (proc (stream-car s))
       (stream-for-each proc (stream-cdr s)))))

(define (display-stream s)
  (stream-for-each
   (lambda (element) (newline) (display element))
   s))

(define (stream-flatmap f s)
  (stream-flatten (stream-map f s)))

(define (stream-append s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1)
                   (stream-append (stream-cdr s1) s2))))

(define (list->stream l)
  (if (null? l)
      the-empty-stream
      (cons-stream (car l) (list->stream (cdr l))) ))

(define (make-stream . elements)
  (list->stream elements))

(define (enumerate-interval low high)
  (if (> low high)
      '()
      (cons low (enumerate-interval (+ low 1) high))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(define (stream-enumerate-interval low high)
  (if (> low high)
      the-empty-stream
      (cons-stream low (stream-enumerate-interval (+ low 1) high))))

(define range stream-enumerate-interval)

(define (stream-filter pred stream)
  (cond ((stream-null? stream) the-empty-stream)
	((pred (stream-car stream))
	 (cons-stream (stream-car stream)
		      (stream-filter pred (stream-cdr stream))))
	(else (stream-filter pred (stream-cdr stream)))))

(define (show-stream strm . args)
  (if (null? args)
      (ss1 strm 10 10)
      (ss1 strm (car args) (car args))))

(define ss show-stream)

(define (ss1 strm this all)
  (cond ((null? strm) '())
	((= this 0) '(...))
	((and (pair? strm) (promise? (cdr strm)))
	 (cons (ss1 (stream-car strm) all all)
	       (ss1 (stream-cdr strm) (- this 1) all)))
	(else strm)))

(define div quotient)

(define /
  (let ((old/ /))
    (lambda args
      (let ((quo (apply old/ args)))
	(if (integer? quo)
	    quo
	    (exact->inexact quo))))))

  4.0 :  has the RRRS 1 + and -1 + built in ; we removed their definitions
;; from here.

(define (nth n l) (list-ref l n))

;; This is a debugging aid for programs with parenthesis problems,
;; according to bh.
(define (load-noisily file-name)
  (define (iter port)
    (let ((the-expression (read port)))
      (cond ((eof-object? the-expression) #t)
	    (else
	     (display (eval the-expression))
	     (newline)
	     (iter port)))))
  (let ((port (open-input-file file-name)))
    (iter port)
    (close-input-port port)
    'ok))


   Get and put for section 2.3

(define (get key1 key2)
  (let ((subtable (assoc key1 (cdr the-get/put-table))))
	(if (not subtable)
		#f
		(let ((record (assoc key2 (cdr subtable))))
		  (if (not record)
			  #f
			  (cdr record))))))

(define (put key1 key2 value)
  (let ((subtable (assoc key1 (cdr the-get/put-table))))
    (if (not subtable)
        (set-cdr! the-get/put-table
                  (cons (list key1
                              (cons key2 value))
                        (cdr the-get/put-table)))
        (let ((record (assoc key2 (cdr subtable))))
          (if (not record)
              (set-cdr! subtable
                        (cons (cons key2 value)
                              (cdr subtable)))
              (set-cdr! record value)))))
  'ok)

(define the-get/put-table (list '*table*))

  Error is like LISP FORMAT in  :

(define error
  (let ((stk-error error))
    (lambda args
      (if (and (not (null? args)) (string-find? "~" (car args)))
	  (apply stk-error args)
	  (stk-error "~A" 
		     (with-output-to-string
		       (lambda ()
			 (for-each (lambda (x) (display x)) args))))))))

;; ROUND returns an inexact integer if its argument is inexact,
;; but we think it should always return an exact integer.
  ( It matters because some Schemes print inexact integers as " +1.0 " . )
  The ( exact 1 ) test is for PC Scheme , in which nothing is exact .
(if (and (inexact? (round (sqrt 2))) (exact? 1))
    (let ((old-round round)
	  (inexact->exact inexact->exact))
      (set! round
	    (lambda (number)
	      (inexact->exact (old-round number)))))
    'no-problem)

;; Remainder and quotient blow up if their argument isn't an integer.
  Unfortunately , in SCM , ( * 365.25 24 60 60 ) * is n't * an integer .

(if (inexact? (* .25 4))
    (let ((rem remainder)
	  (quo quotient)
	  (inexact->exact inexact->exact)
	  (integer? integer?))
      (set! remainder
	    (lambda (x y)
	      (rem (if (integer? x) (inexact->exact x) x)
		   (if (integer? y) (inexact->exact y) y))))
      (set! quotient
	    (lambda (x y)
	      (quo (if (integer? x) (inexact->exact x) x)
		   (if (integer? y) (inexact->exact y) y)))))
    'done)

;; Random
  4.0 :  has  , but it needs a little initialization in order
;; to give interesting numbers.

(require "posix")
(set-random-seed! (posix-time))

(define-macro (repeat . args)
	     `(repeat-helper ,(car args) (lambda () . ,(cdr args))))

(define (repeat-helper num thunk)
  (if (<= num 0)
      'done
      (begin (thunk) (repeat-helper (- num 1) thunk))))

(define call/cc call-with-current-continuation)

(define *old-repl-display-result* repl-display-result)

(define repl-display-result print)

(define (infinite-print flag)
  (if flag
      (set! repl-display-result *old-repl-display-result*)
      (set! repl-display-result print)))

Added this because keywords should be symbols according to BH .
(define symbol? 
  (let ((old-symbol? symbol?))
    (lambda (x) (or (old-symbol? x) (keyword? x)))))

  02/02/2005 : Added as requested by Professors
(define (1+ n) (+ n 1))
(define (-1+ n) (- n 1))

;
  NOTE : THE MASTER COPY OF THIS FILE IS MAINTAINED BY EECS INSTRUCTIONAL
  SUPPORT . IF YOU MAKE CHANGES HERE THEY WILL GO AWAY .
;

(provide "berkeley")



 STk compatibility and to remove dead code.

 4.02.01: Remove definition of read.
 Removed 
 though the values of a, b, m may not be very "appropriately chosen"
Note: logical-and should test for valid signals, as logical-not does
 concurrency stuff
  and added alarm-signal-handler stuff
 For timer interrupts in STk:
Evaluate and accumulate n terms of the series s at the given x
 Streams:
 Restrict the domain of FORCE to include only promises.
 we removed their definitions
 from here.
 This is a debugging aid for programs with parenthesis problems,
 according to bh.
 ROUND returns an inexact integer if its argument is inexact,
 but we think it should always return an exact integer.
 Remainder and quotient blow up if their argument isn't an integer.
 Random
 to give interesting numbers.


  berkeley.scm 4.03.01 Tue Jul 22 17:22:59 2003
  NOTE : THE MASTER COPY OF THIS FILE IS MAINTAINED BY EECS INSTRUCTIONAL
  SUPPORT . IF YOU MAKE CHANGES HERE THEY WILL GO AWAY .
  Compatibility library for UCB Scheme ( STk 4.0.1 derivative ) as used
  in CS61A and CS3 . Over - hauled in May 2000 and April 2003 for

(define nil '())
(define true #t)
(define false #f)

  4.0 :  already has a time program , so I nuked time
  4.0 : STk load already has glob built in , so I nuked redef . of load


  SICP stuff :

(define (print x)
  (write x)
  (newline))

  Define tagged data ADT :

(define (attach-tag type-tag contents)
  (cons type-tag contents))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum)))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum -- CONTENTS" datum)))

For Section 3.1.2 -- written as suggested in footnote ,
(define (rand-update x)
  (let ((a 27) (b 26) (m 127))
    (modulo (+ (* a x) b) m)))

For Section 3.3.4 , used by and - gate
(define (logical-and x y)
  (if (and (= x 1) (= y 1))
      1
      0))


  4.0 : Simplified these somewhat -- removed tests for scm

(define (alarm-signal-handler sig) (alarm-interrupt))
(add-signal-handler! 14 alarm-signal-handler)

(require 'process)

(define test-and-set!
	     (let ((arb (make-arbiter 'scratchnsniff)))
	       (lambda (cell)
		 (if (try-arbiter arb)
		     (begin (process:schedule!)
			    (test-and-set! cell))
		     (let ((result (car cell)))
		       (set-car! cell #t)
		       (release-arbiter arb)
		       result)))))

(define (parallel-execute . thunks)
	     (for-each (lambda (thunk) (add-process! (lambda (foo) (thunk))))
		       thunks)
	     (alarm-interrupt)
	     (process:schedule!))

(define (stop) (alarm 0) (set! process:queue (make-queue)))

For Section 3.5.2 , to check power series ( exercises 3.59 - 3.62 )
Uses    from ex 2.34
(define (eval-power-series s x n)
  (horner-eval x (first-n-of-series s n)))
(define (first-n-of-series s n)
  (if (= n 0)
      '()
      (cons (stream-car s) (first-n-of-series (stream-cdr s) (- n 1)))))

  4.0 : We do not redefine promises as procedures anymore .

(define force
  (let ((force force))
    (lambda (p)
      (if (not (promise? p))
          (error "Not a promise: " p)
          (force p)))))

(define-macro (cons-stream . args) 
              `(cons ,(car args) (delay ,(cadr args))))

(define (stream-car stream) (car stream))

(define (stream-cdr st)
  (force (cdr st)))

(define the-empty-stream '())

(define (stream-null? stream) (eq? stream the-empty-stream))

(define (stream? obj)
  (or (stream-null? obj)
      (and (pair? obj) (promise? (cdr obj)))))

(define (stream-accumulate combiner initial-value stream)
  (if (stream-null? stream)
      initial-value
      (combiner (stream-car stream)
		(stream-accumulate combiner
				   initial-value
				   (stream-cdr stream)))))

(define (accumulate-delayed combiner initial-value stream)
  (if (stream-null? stream)
      initial-value
      (combiner (stream-car stream)
                (delay
                 (accumulate-delayed combiner
                                     initial-value
                                     (stream-cdr stream))))))

(define (interleave s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1)
                   (interleave s2 (stream-cdr s1)))))

(define (interleave-delayed s1 delayed-s2)
  (if (stream-null? s1)
      (force delayed-s2)
      (cons-stream (stream-car s1)
                   (interleave-delayed (force delayed-s2)
                                       (delay (stream-cdr s1))))))

(define (stream-flatten stream)
  (accumulate-delayed interleave-delayed
                      the-empty-stream
                      stream))

(define (stream-ref s n)
  (if (= n 0)
      (stream-car s)
      (stream-ref (stream-cdr s) (- n 1))))

(define (stream-map proc . s)
  (if (stream-null? (car s))
      the-empty-stream
      (cons-stream (apply proc (map stream-car s))
                   (apply stream-map proc (map stream-cdr s)))))

(define (stream-for-each proc s)
  (if (stream-null? s)
      'done
      (begin
       (proc (stream-car s))
       (stream-for-each proc (stream-cdr s)))))

(define (display-stream s)
  (stream-for-each
   (lambda (element) (newline) (display element))
   s))

(define (stream-flatmap f s)
  (stream-flatten (stream-map f s)))

(define (stream-append s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1)
                   (stream-append (stream-cdr s1) s2))))

(define (list->stream l)
  (if (null? l)
      the-empty-stream
      (cons-stream (car l) (list->stream (cdr l))) ))

(define (make-stream . elements)
  (list->stream elements))

(define (enumerate-interval low high)
  (if (> low high)
      '()
      (cons low (enumerate-interval (+ low 1) high))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(define (stream-enumerate-interval low high)
  (if (> low high)
      the-empty-stream
      (cons-stream low (stream-enumerate-interval (+ low 1) high))))

(define range stream-enumerate-interval)

(define (stream-filter pred stream)
  (cond ((stream-null? stream) the-empty-stream)
	((pred (stream-car stream))
	 (cons-stream (stream-car stream)
		      (stream-filter pred (stream-cdr stream))))
	(else (stream-filter pred (stream-cdr stream)))))

(define (show-stream strm . args)
  (if (null? args)
      (ss1 strm 10 10)
      (ss1 strm (car args) (car args))))

(define ss show-stream)

(define (ss1 strm this all)
  (cond ((null? strm) '())
	((= this 0) '(...))
	((and (pair? strm) (promise? (cdr strm)))
	 (cons (ss1 (stream-car strm) all all)
	       (ss1 (stream-cdr strm) (- this 1) all)))
	(else strm)))

(define div quotient)

(define /
  (let ((old/ /))
    (lambda args
      (let ((quo (apply old/ args)))
	(if (integer? quo)
	    quo
	    (exact->inexact quo))))))


(define (nth n l) (list-ref l n))

(define (load-noisily file-name)
  (define (iter port)
    (let ((the-expression (read port)))
      (cond ((eof-object? the-expression) #t)
	    (else
	     (display (eval the-expression))
	     (newline)
	     (iter port)))))
  (let ((port (open-input-file file-name)))
    (iter port)
    (close-input-port port)
    'ok))


   Get and put for section 2.3

(define (get key1 key2)
  (let ((subtable (assoc key1 (cdr the-get/put-table))))
	(if (not subtable)
		#f
		(let ((record (assoc key2 (cdr subtable))))
		  (if (not record)
			  #f
			  (cdr record))))))

(define (put key1 key2 value)
  (let ((subtable (assoc key1 (cdr the-get/put-table))))
    (if (not subtable)
        (set-cdr! the-get/put-table
                  (cons (list key1
                              (cons key2 value))
                        (cdr the-get/put-table)))
        (let ((record (assoc key2 (cdr subtable))))
          (if (not record)
              (set-cdr! subtable
                        (cons (cons key2 value)
                              (cdr subtable)))
              (set-cdr! record value)))))
  'ok)

(define the-get/put-table (list '*table*))

  Error is like LISP FORMAT in  :

(define error
  (let ((stk-error error))
    (lambda args
      (if (and (not (null? args)) (string-find? "~" (car args)))
	  (apply stk-error args)
	  (stk-error "~A" 
		     (with-output-to-string
		       (lambda ()
			 (for-each (lambda (x) (display x)) args))))))))

  ( It matters because some Schemes print inexact integers as " +1.0 " . )
  The ( exact 1 ) test is for PC Scheme , in which nothing is exact .
(if (and (inexact? (round (sqrt 2))) (exact? 1))
    (let ((old-round round)
	  (inexact->exact inexact->exact))
      (set! round
	    (lambda (number)
	      (inexact->exact (old-round number)))))
    'no-problem)

  Unfortunately , in SCM , ( * 365.25 24 60 60 ) * is n't * an integer .

(if (inexact? (* .25 4))
    (let ((rem remainder)
	  (quo quotient)
	  (inexact->exact inexact->exact)
	  (integer? integer?))
      (set! remainder
	    (lambda (x y)
	      (rem (if (integer? x) (inexact->exact x) x)
		   (if (integer? y) (inexact->exact y) y))))
      (set! quotient
	    (lambda (x y)
	      (quo (if (integer? x) (inexact->exact x) x)
		   (if (integer? y) (inexact->exact y) y)))))
    'done)

  4.0 :  has  , but it needs a little initialization in order

(require "posix")
(set-random-seed! (posix-time))

(define-macro (repeat . args)
	     `(repeat-helper ,(car args) (lambda () . ,(cdr args))))

(define (repeat-helper num thunk)
  (if (<= num 0)
      'done
      (begin (thunk) (repeat-helper (- num 1) thunk))))

(define call/cc call-with-current-continuation)

(define *old-repl-display-result* repl-display-result)

(define repl-display-result print)

(define (infinite-print flag)
  (if flag
      (set! repl-display-result *old-repl-display-result*)
      (set! repl-display-result print)))

Added this because keywords should be symbols according to BH .
(define symbol? 
  (let ((old-symbol? symbol?))
    (lambda (x) (or (old-symbol? x) (keyword? x)))))

  02/02/2005 : Added as requested by Professors
(define (1+ n) (+ n 1))
(define (-1+ n) (- n 1))

  NOTE : THE MASTER COPY OF THIS FILE IS MAINTAINED BY EECS INSTRUCTIONAL
  SUPPORT . IF YOU MAKE CHANGES HERE THEY WILL GO AWAY .

(provide "berkeley")
