personal-helpers/helpful.body.scm

(define (value->procedure val)
  (lambda () val))

(define (list->procedure l)
  (lambda (i)
    (list-ref l i)))

(define (vector->procedure v)
  (lambda (i)
    (vector-ref v i)))

(define (string->procedure s)
  (lambda (i)
    (string-ref s i)))

(define (assq->procedure al)
  (lambda (key)
    (cdr (assq key al))))

(define (assv->procedure al)
  (lambda (key)
    (cdr (assv key al))))

(define (assoc->procedure al)
  (lambda (key)
    (cdr (assoc key al))))

(define (assq-ref al k)
  (cdr (assq k al)))

(define (assv-ref al k)
  (cdr (assv k al)))

(define (assoc-ref al k)
  (cdr (assoc k al)))

(define (print . l)
  (for-each display l)
  (newline))

(define (each-assoc key alist op)
  ;; helper for memoize -- generic assoc for list keys
  (if (null? alist)
      #f
      (if (and (= (length key) (length (caar alist)))
               (let loop ((alist-key-in (caar alist))
                          (input-key-in key))
                 (cond
                  ((null? alist-key-in)
                   #t)
                  ((op (car alist-key-in) (car input-key-in))
                   (loop (cdr alist-key-in)
                         (cdr input-key-in)))
                  (else
                   #f))))
          (car alist)
          (each-assoc key (cdr alist) op))))

(define-syntax memoize
  (syntax-rules ()
    ((_ op proc)
     (let ((cache '()))
       (lambda args
         (let ((cache-reference (each-assoc args cache op)))
           (if cache-reference
               (cadr cache-reference)
               (let ((result (apply proc args)))
                 (set! cache (cons (list args result) cache))
                 result))))))))

(define-syntax memoize-testing
  (syntax-rules ()
    ((_ op proc)
     (let ((cache '()))
       (lambda args
         (write cache)
         (newline)
         (let ((cache-reference (each-assoc args cache op)))
           (if cache-reference
               (cadr cache-reference)
               (let ((result (apply proc args)))
                 (set! cache (cons (list args result) cache))
                 result))))))))

(define (atom? val)
  (not (or (null? val) (pair? val))))

(define (flatten l)
  (cond
   ((list? l) (apply append (map flatten l)))
   (else (list l))))

(define (pair-conjugate p)
  (cons (cdr p) (car p)))

(define (complex-conjugate c)
  (+ (real-part c) (* 0-i (imag-part c))))

(define (integer->hex n)
  (define hex-selection
    (assv->procedure
     '((0 . #\0) (1 . #\1) (2 . #\2) (3 . #\3) (4 . #\4)
       (5 . #\5) (6 . #\6) (7 . #\7) (8 . #\8) (9 . #\9)
       (10 . #\a) (11 . #\b) (12 . #\c) (13 . #\d)
       (14 . #\e) (15 . #\f))))
    
  (define (build-hex next-num previous-list)
    (cons (hex-selection (modulo next-num 16))
          previous-list))

  (when (or (negative? n) (not (integer? n)))
    (error "integer->hex" "Non-negative integer expected"))

  (let loop ((in n) (out '()))
    (if (= in 0)
        (list->string out)
        (loop (quotient in 16)
              (build-hex in out)))))

(define (integer->bin n)
  (define (build-bin next-num previous-list)
    (cons (if (even? next-num) #\0 #\1)
          previous-list))

  (when (or (negative? n) (not (integer? n)))
    (error "integer->bin" "Non-negative integer expected"))

  (let loop ((in n) (out '()))
    (if (= in 0)
        (if (null? out)
            "0"
            (list->string out))
        (loop (quotient in 2)
              (build-bin in out)))))

(define (hex->integer h)
  (define hex-deselection
    (assv->procedure
     '((#\0 . 0) (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4)
       (#\5 . 5) (#\6 . 6) (#\7 . 7) (#\8 . 8) (#\9 . 9)
       (#\a . 10) (#\b . 11) (#\c . 12) (#\d . 13)
       (#\e . 14) (#\f . 15))))

  (define (debuild-hex next-char previous-num)
    (+ (hex-deselection (char-downcase next-char))
       (* 16 previous-num)))

  (let loop ((in (string->list h)) (out 0))
    (if (null? in)
        out
        (loop (cdr in)
              (debuild-hex (car in) out)))))

(define (bin->integer b)
  (define (debuild-bin next-char previous-num)
    (+ (if (eqv? next-char #\0) 0 1)
       (* previous-num 2)))

  (let loop ((in (string->list b)) (out 0))
    (if (null? in)
        out
        (loop (cdr in)
              (debuild-bin (car in) out)))))

(define (bin->hex b)
  (integer->hex (bin->integer b)))

(define (hex->bin h)
  (integer->bin (hex->integer h)))

(define (pad-string-helper input-string desired-size padding-char left?)
  (let ((actual-size (string-length input-string)))
    (if (< actual-size desired-size)
        (if left?
            (string-append (make-string (- desired-size actual-size)
                                        padding-char)
                           input-string)
            (string-append input-string
                           (make-string (- desired-size actual-size)
                                        padding-char)))
        input-string)))

(define pad-left
  (case-lambda
   ((st sz)
    (pad-string-helper st sz #\space #t))
   ((st sz chr)
    (pad-string-helper st sz chr #t))))

(define pad-right
  (case-lambda
   ((st sz)
    (pad-string-helper st sz #\space #f))
   ((st sz chr)
    (pad-string-helper st sz chr #f))))

(define (color-string->triplet cs)
  (define (select-one-hex n)
    (hex->integer (string (string-ref cs n)
                          (string-ref cs n))))
  
  (define (select-two-hexes n)
    (hex->integer (string (string-ref cs n)
                          (string-ref cs (+ n 1)))))

  (cond
   ((= (string-length cs) 3)
    (list (select-one-hex 0)
          (select-one-hex 1)
          (select-one-hex 2)))
   ((= (string-length cs) 6)
    (list (select-two-hexes 0)
          (select-two-hexes 2)
          (select-two-hexes 4)))
   (else
    (error "color-string->triplet" "String must be of length 3 or 6" cs))))

(define (triplet->color-string trip)
  (unless (and (= (length trip) 3)
               (<= 0 (list-ref trip 0) 255)
               (<= 0 (list-ref trip 1) 255)
               (<= 0 (list-ref trip 2) 255)
               (integer? (list-ref trip 0))
               (integer? (list-ref trip 1))
               (integer? (list-ref trip 2)))
    (error "triplet->color-string"
      "Argument must be a triplet of integers 0 to 255" trip))

  (apply string-append (map (lambda (n)
                              (pad-left (integer->hex n) 2 #\0))
                            trip)))

(define (test-for-each? proc l . rest)
  (let ((test-result (apply map proc l rest)))
    (not (memv #f test-result))))

(define (properize p)
  (if (pair? (cdr p))
      (cons (car p) (properize (cdr p)))
      (list (car p) (cdr p))))

(define (improperize p)
  (if (pair? (cddr p))
      (cons (car p) (improperize (cdr p)))
      (cons (car p) (cadr p))))

(define-syntax assert
  (syntax-rules ()
    ((_ expr)
     (unless expr
       (error "Assertion failed" 'expr)))))

(define-syntax logging
  (syntax-rules ()
    ((_ (expr ...))
     (begin
       (display "LOGGING: ")
       (write '(expr ...))
       (newline)))
    ((_ expr)
     (begin
       (display "LOGGING: ")
       (write 'expr)
       (display " = ")
       (write expr)
       (newline)))
    ((_ expr rest ...)
     (begin
       (logging expr)
       (logging rest ...)))))

(define (read-entire-file path)
  (define p (open-input-file path))
  (let loop ((out '())
             (next-char (read-char p)))
    (if (eof-object? next-char)
        (let ((result (list->string (reverse out))))
          (close-input-port p)
          result)
        (loop (cons next-char out)
              (read-char p)))))

(define (join joiner proc a b)
  (define (join-on-b a-val)
    (let loop ((out '())
               (in b))
      (if (null? in)
          (reverse out)
          (loop (if (proc a-val (car in))
                    (cons (joiner a-val (car in))
                          out)
                    out)
                (cdr in)))))
  (apply append (map join-on-b a)))

(define (op-table proc a b)
  (map (lambda (aa)
         (map (lambda (bb)
                (proc aa bb))
              b))
       a))

(define (snoc rest new-last)
  (append rest (list new-last)))

(define (combine2 joiner l1 l2)
  (apply append 
         (map (lambda (x)
                (map (lambda (y)
                       (joiner x y)) l2)) l1)))

(define (combine . l)
  (reduce (lambda (l1 l2)
            (combine2 append l1 l2))
          '()
          l))

(define (symbol-list->string sl)
  (apply string-append (map symbol->string sl)))

(define (curry proc)
  (lambda (a) (lambda b (apply proc (cons a b)))))

(define (uncurry proc)
  (lambda b (apply (proc (car b)) (cdr b))))

(define (papply proc . values)
  (lambda args (apply proc (append values args))))

(define left-papply papply)

(define (right-papply proc . values)
  (lambda args (apply proc (append args values))))

(define (pmap proc . args)
  (papply map (apply papply proc args)))

(define (list-set l i value)
  (let loop ((front '())
             (back l)
             (count 0))
    (if (< count i)
        (loop (cons (car back) front)
              (cdr back)
              (+ count 1))
        (append (reverse front)
                (list value)
                (cdr back)))))

(define (concordance test l)
  (define (update-concordance test value l)
    (define (find-index)
      (let loop ((in l) (out 0))
        (if (null? in)
            (values #f #f)
            (if (test (caar in) value)
                (values out (car in))
                (loop (cdr in) (+ out 1))))))

    (define-values (index found-concordance)
      (find-index))
    
    (if index
        (list-set l index (cons (car found-concordance)
                                (cons value (cdr found-concordance))))
        (cons (list value) l)))

  (let loop ((in l) (out '()))
    (if (null? in)
        (reverse (map (lambda (l) (cons (car l) (length l))) out))
        (loop (cdr in) (update-concordance test (car in) out)))))

(define (concord= l) (concordance = l))

(define (concordq l) (concordance eq? l))

(define (concordv l) (concordance eqv? l))

(define (structure-apply to-list)
  (lambda (proc arg1 . arg-rest)
    (define args (cons arg1 arg-rest))
    (let loop ((back args) (front '()))
      (if (null? (cdr back))
          (apply proc (append (reverse front) (to-list (car back))))
          (loop (cdr back) (cons (car back) front))))))

(define vector-apply (structure-apply vector->list))

(define string-apply (structure-apply string->list))

(define (fractional-to-fixed inexact-num digits)
  ;; helper for to-fixed
  ;; assumes that digits is at least 1
  (define num (exact inexact-num))

  (define (fetch-digit num place)
    (integer->char (+ 48 (modulo (floor (/ num place)) 10))))

  (define (rounded-fraction frac-part)
    (exact (/ (round (* frac-part (expt 10 digits))) (expt 10 digits))))

  (define integral-part (exact (floor num)))
  (define fractional-part (rounded-fraction (- num integral-part)))

  (if (= 1 fractional-part)
      (fractional-to-fixed (+ integral-part 1) digits)
      (let loop ((result '(#\.))
                 (count 0)
                 (place 1/10))
        (if (< count digits)
            (loop (cons (fetch-digit fractional-part place) result)
                  (+ count 1)
                  (/ place 10))
            (string-append (number->string integral-part)
                           (list->string (reverse result)))))))

(define (to-fixed num digits)
  ;; digits must be between 0 and 30
  (cond
   ((= digits 0)
    (number->string (exact (round num))))
   ((<= 1 digits 30)
    (fractional-to-fixed num digits))
   (else
    (error "to-fixed" "digits must be between 0 and 30 inclusive"))))

(define (order-of-magnitude num)
  (exact (floor (/ (log num) (log 10)))))

(define (to-exponential-with-digits num digits)
  (define oom (order-of-magnitude num))

  (define coefficient (/ num (expt 10 oom)))

  (define rounded-coefficient
    (exact (/ (round (* (expt 10 digits) coefficient)) (expt 10 digits))))

  (define corrected-coefficient
    ;; this is necessary in case the number rounded up
    (if (>= rounded-coefficient 10)
        (/ rounded-coefficient 10)
        coefficient))

  (define corrected-oom
    (if (>= rounded-coefficient 10)
        (+ oom 1)
        oom))

  (string-append
   (fractional-to-fixed corrected-coefficient digits)
   "e"
   (number->string corrected-oom)))

(define (to-exponential-with-digits-check-digits num digits)
  ;; digits must be between 0 and 30
  (cond
   ((<= 0 digits 30)
    (to-exponential-with-digits num digits))
   (else
    (error "to-exponential" "digits must be between 0 and 30 inclusive"))))

(define (to-exponential-without-digits num)
  (define oom (order-of-magnitude num))

  (define coefficient (inexact (/ num (expt 10 oom))))

  (string-append
   (number->string coefficient)
   "e"
   (number->string oom)))

(define to-exponential
  (case-lambda
   ((num) (to-exponential-without-digits num))
   ((num digits) (to-exponential-with-digits-check-digits num digits))))

(define (pipe init . args)
  ;; evaluate init by a sequence of procedures
  ;; most useful in conjunction with papply
  (let loop ((result init)
             (procs args))
    (if (null? procs)
        result
        (loop ((car procs) result)
              (cdr procs)))))

(define (list-split pred? l)
  (let loop ((in l)
             (out '(())))
    (if (null? in)
        (reverse (cons (reverse (car out)) (cdr out)))
        (loop (cdr in)
              (if (pred? (car in))
                  (cons '() (cons (reverse (car out)) (cdr out)))
                  (cons (cons (car in) (car out))
                        (cdr out)))))))

(define (string-split pred? s)
 (map list->string (list-split pred? (string->list s))))

(define (iden p) p)

(define (inc n) (+ n 1))

(define (dec n) (- n 1))

(define (alist-mapper symbol-map)
  (lambda (obj)
    (apply append
           (map (lambda (kvp)
                  (let ((from (car kvp))
                        (to (cdr kvp)))
                    (let ((from-pair (assq from obj)))
                      (if from-pair
                          (list (cons to (cdr from-pair)))
                          '()))))
                symbol-map))))

(define (repeated op n)
  (unless (and (integer? n)
               (>= n 0))
    (error "Expected a non-negative integer but got" n))
  (lambda (init)
    (let loop ((i n)
               (v init))
      (if (= i 0)
          v
          (loop (- i 1)
                (op v))))))