learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

utils.scm (3502B)

      1 (define-library (sicp utils)
      2   (export
      3    *debug*
      4    accumulate
      5    debug!
      6    debug?
      7    dp
      8    dpp
      9    enumerate-interval
     10    filter
     11    flatmap
     12    pp
     13    )
     14   (import (scheme base)
     15           (scheme write)
     16 
     17           (ice-9 pretty-print)
     18 
     19           (srfi srfi-1)
     20           (srfi srfi-19)
     21           (srfi srfi-28)
     22 
     23           ;;(prefix (guile) guile:)
     24           (only (guile)
     25                 define*
     26                 define-syntax-rule
     27                 current-source-location))
     28 
     29   (begin
     30     (define *debug* #f)
     31     (define* (debug! #:optional x)
     32       (if x
     33           (set! *debug* (not *debug*))
     34           (set! *debug* x)))
     35     (define (debug?) *debug*)
     36 
     37     (define nil '())
     38 
     39     (define-syntax-rule (dp x)
     40       ;; Debug Print.
     41       (when (debug?)
     42         (let* ((loc (current-source-location))
     43                (line-number (cdr (assoc 'line loc eq?)))
     44                (column-number (cdr (assoc 'column loc eq?)))
     45                (x-val x))
     46           (display (+ line-number 1))
     47           (display ":")
     48           (display column-number)
     49           (display ":")
     50           (newline)
     51           (write (quote x))
     52           (newline)
     53           (display " = " )
     54           (newline)
     55           (write x-val)
     56           (display "\n\n")
     57           x-val)))
     58 
     59     (define-syntax-rule (dpp x)
     60       ;; Debug Pretty Print.
     61       (when (debug?)
     62         (let* ((loc (current-source-location))
     63                (line-number (cdr (assoc 'line loc eq?)))
     64                (column-number (cdr (assoc 'column loc eq?)))
     65                (x-val x))
     66           (display (+ line-number 1))
     67           (display ":")
     68           (display column-number)
     69           (display ":")
     70           (newline)
     71           (pretty-print (quote x))
     72           (display "=> ")
     73           (pretty-print x-val)
     74           (newline)
     75           x-val)))
     76 
     77     (define (pp x)
     78       (pretty-print x))
     79 
     80     (define (filter predicate sequence)
     81       ;; From 2.2.3 Sequences as Conventional Interfaces
     82       (cond ((null? sequence) nil)
     83             ((predicate (car sequence))
     84              (cons (car sequence)
     85                    (filter predicate
     86                            (cdr sequence))))
     87             (else  (filter predicate
     88                            (cdr sequence)))))
     89 
     90     (define (enumerate-interval low high)
     91       ;; (iota (- high low -1) low)
     92       ;; From 2.2.3 Sequences as Conventional Interfaces
     93       (if (> low high)
     94           '()
     95           (cons low
     96                 (enumerate-interval (+ 1 low)
     97                                     high))))
     98 
     99     (define (accumulate op initial sequence)
    100       ;; From 2.2.3 Sequences as Conventional Interfaces
    101       (if (null? sequence)
    102           initial
    103           (op (car sequence)
    104               (accumulate op
    105                           initial
    106                           (cdr sequence)))))
    107 
    108     (define (flatmap proc seq)
    109       (accumulate append
    110                   '()
    111                   (map proc seq)))
    112 
    113     (define (current-time->microseconds t)
    114       (let* ((start-seconds (time-second start-time))
    115              (start-nanoseconds (time-nanosecond start-time)))
    116         (+ (* start-seconds (expt 10 6))
    117            (quotient start-nanoseconds
    118                      (expt 10 3)))))
    119 
    120     '(define runtime
    121       (let* ((start-time (current-time time-utc))
    122              (start-microseconds (current-time->microseconds start-time)))
    123 
    124         (lambda ()
    125           (let* ((t (current-time time-utc))
    126                  (t-microseconds (current-time->microseconds t)))
    127             (- start-microseconds t-microseconds)))))
    128     ))