Chez Scheme Setup

October 3, 2017


(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (split n xs)
  (let loop ((n n) (xs xs) (zs '()))
    (if (or (zero? n) (null? xs))
        (values (reverse zs) xs)
        (loop (- n 1) (cdr xs) (cons (car xs) zs)))))

(define (take-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (reverse ys)
        (loop (cdr xs) (cons (car xs) ys)))))

(define (drop-while pred? xs)
  (let loop ((xs xs))
    (if (or (null? xs) (not (pred? (car xs)))) xs
      (loop (cdr xs)))))

(define (split-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (values (reverse ys) xs)
        (loop (cdr xs) (cons (car xs) ys)))))

; (define (cons* first . rest)
;   (let loop ((curr first) (rest rest))
;     (if (null? rest) curr
;         (cons curr (loop (car rest) (cdr rest))))))

; (define (fold-left op base xs)
;   (if (null? xs)
;       base
;       (fold-left op (op base (car xs)) (cdr xs))))

; (define (fold-right op base xs)
;   (if (null? xs)
;       base
;       (op (car xs) (fold-right op base (cdr xs)))))

(define range
    ((stop) (range 0 stop (if (negative? stop) -1 1)))
    ((start stop) (range start stop (if (= string (map char-upcase (string->list str))))

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

(define (string-find pat str . s)
  (let* ((plen (string-length pat))
         (slen (string-length str))
         (skip (make-vector plen 0)))
    (let loop ((i 1) (j 0))
      (cond ((= i plen))
            ((char=? (string-ref pat i) (string-ref pat j))
              (vector-set! skip i (+ j 1))
              (loop (+ i 1) (+ j 1)))
            ((< 0 j) (loop i (vector-ref skip (- j 1))))
            (else (vector-set! skip i 0)
                  (loop (+ i 1) j))))
    (let loop ((p 0) (s (if (null? s) 0 (car s))))
      (cond ((= s slen) #f)
            ((char=? (string-ref pat p) (string-ref str s))
              (if (= p (- plen 1))
                  (- s plen -1)
                  (loop (+ p 1) (+ s 1))))
            ((< 0 p) (loop (vector-ref skip (- p 1)) s))
            (else (loop p (+ s 1)))))))

; (define sort #f)
; (define merge #f)
; (let ()
;   (define dosort
;     (lambda (pred? ls n)
;       (if (= n 1)
;           (list (car ls))
;           (let ((i (quotient n 2)))
;             (domerge pred?
;                      (dosort pred? ls i)
;                      (dosort pred? (list-tail ls i) (- n i)))))))
;   (define domerge
;     (lambda (pred? l1 l2)
;       (cond
;         ((null? l1) l2)
;         ((null? l2) l1)
;         ((pred? (car l2) (car l1))
;          (cons (car l2) (domerge pred? l1 (cdr l2))))
;         (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
;   (set! sort
;     (lambda (pred? l)
;       (if (null? l) l (dosort pred? l (length l)))))
;   (set! merge
;     (lambda (pred? l1 l2)
;       (domerge pred? l1 l2))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1
                        (cons (cons prev k) result)))))))

; vector-sort and vector-sort! are provided natively by chez scheme,
; but differ from the standard prelude in how they take arguments;
; we defer to chez scheme for vector-sort and vector-sort!

(define (identity x) x)

(define (constant x) (lambda ys x))

(define (fst x y) x)

(define (snd x y) y)

(define (compose . fns)
  (let comp ((fns fns))
      ((null? fns) 'error)
      ((null? (cdr fns)) (car fns))
        (lambda args
            (lambda ()
                (comp (cdr fns))
            (car fns)))))))

(define (complement f) (lambda xs (not (apply f xs))))

(define (swap f) (lambda (x y) (f y x)))

(define (left-section proc . args)
  (lambda xs (apply proc (append args xs))))

(define (right-section proc . args)
  (lambda xs (apply proc (reverse (append (reverse args) (reverse xs))))))

(define-syntax curried-lambda
  (syntax-rules ()
    ((_ () body body* ...)
      (begin body body* ...))
    ((_ (arg arg* ...) body body* ...)
      (lambda (arg)
        (curried-lambda (arg* ...)
          body body* ...)))))

(define-syntax define-curried
  (syntax-rules ()
    ((_ (func arg ...) body body* ...)
      (define func
        (curried-lambda (arg ...)
          body body* ...)))))

(define (ipow b e)
  (if (= e 0) 1
    (let loop ((s b) (i e) (a 1)) ; a * s^i = b^e
      (let ((a (if (odd? i) (* a s) a)) (i (quotient i 2)))
        (if (zero? i) a (loop (* s s) i a))))))

; (define (isqrt n)
;   (if (not (and (positive? n) (integer? n)))
;       (error 'isqrt "must be positive integer")
;       (let loop ((x n))
;         (let ((y (quotient (+ x (quotient n x)) 2)))
;           (if (< y x) (loop y) x)))))

(define (ilog b n)
  (let loop1 ((lo 0) (b^lo 1) (hi 1) (b^hi b))
    (if (< b^hi n) (loop1 hi b^hi (* hi 2) (* b^hi b^hi))
      (let loop2 ((lo lo) (b^lo b^lo) (hi hi) (b^hi b^hi))
        (if (<= (- hi lo) 1) (if (= b^hi n) hi lo)
          (let* ((mid (quotient (+ lo hi) 2))
                 (b^mid (* b^lo (expt b (- mid lo)))))
            (cond ((< n b^mid) (loop2 lo b^lo mid b^mid))
                  ((< b^mid n) (loop2 mid b^mid hi b^hi))
                  (else mid))))))))

(define (expm b e m)
  (define (m* x y) (modulo (* x y) m))
  (cond ((zero? e) 1)
        ((even? e) (expm (m* b b) (/ e 2) m))
        (else (m* b (expm (m* b b) (/ (- e 1) 2) m)))))

(define (halve x) (/ x 2))

(define (double x) (+ x x))

(define (square x) (* x x))

; (define (add1 x) (+ x 1))

; (define (sub1 x) (- x 1))

(define (log2 x) (/ (log x) (log 2)))

(define (log10 x) (/ (log x) (log 10)))

(define (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(define (undigits ds . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((ds ds) (n 0))
      (if (null? ds) n
          (loop (cdr ds) (+ (* n b) (car ds)))))))

; (define (logand a b)
;   (if (or (zero? a) (zero? b)) 0
;     (+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
;        (if (or (even? a) (even? b)) 0 1))))

; (define (logior x y)
;   (cond ((= x y) x)
;         ((zero? x) y)
;         ((zero? y) x)
;         (else
;           (+ (* (logior (quotient x 2) (quotient y 2)) 2)
;             (if (and (even? x) (even? y)) 0 1)))))

; (define (logxor a b)
;   (cond ((zero? a) b)
;         ((zero? b) a)
;         (else
;          (+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
;             (if (even? a)
;                 (if (even? b) 0 1)
;                 (if (even? b) 1 0))))))

; (define (lognot a) (- -1 a))

; (define (ash int cnt)
;   (if (negative? cnt)
;       (let ((n (expt 2 (- cnt))))
;         (if (negative? int)
;             (+ -1 (quotient (+ 1 int) n))
;             (quotient int n)))
;       (* (expt 2 cnt) int)))

(define (make-bitvector len . val)
  (let ((v (make-vector
             (ceiling (/ len 8))
             (if (and (pair? val) (= (car val) 1)) 255 0))))
    (if (and (pair? val) (= (car val) 1) (not (zero? (modulo len 8))))
      (do ((i 8 (- i 1))) ((= i (modulo len 8)))
        (vector-set! v (floor (/ len 8))
          (logand (vector-ref v (floor (/ len 8)))
                  (lognot (ash 1 (- i 1)))))))
    (cons v len)))

(define (bitvector-ref bv idx)
  (if (< -1 idx (cdr bv))
      (let ((index (quotient idx 8)) (offset (modulo idx 8)))
        (if (odd? (ash (vector-ref (car bv) index) (- offset))) 1 0))
      (error 'bitvector-ref "out of range")))

(define (bitvector-set! bv idx)
  (if (syntax name
        (string-append "residual-"
          (symbol->string (syntax->datum name))))))
  (syntax-case x (lambda)
    ((_ (name . args) . body)
      (syntax (define-integrable name (lambda args . body))))
    ((_ name (lambda formals form1 form2 ...))
     (identifier? (syntax name))
     (with-syntax ((xname (make-residual-name (syntax name))))
           (define-syntax (name x)
             (syntax-case x ()
               (_ (identifier? x) (syntax xname))
               ((_ arg (... ...))
                     ((name (identifier-syntax xname)))
                     (lambda formals form1 form2 ...))
                   arg (... ...))))))
           (define xname
             (fluid-let-syntax ((name (identifier-syntax xname)))
               (lambda formals form1 form2 ...)))))))))

(define-syntax (define-macro x)
  (syntax-case x ()
    ((_ (name . args) . body)
      (syntax (define-macro name (lambda args . body))))
    ((_ name transformer)
       (define-syntax (name y)
         (syntax-case y ()
           ((_ . args)
               (syntax _)
               (apply transformer
                 (syntax->datum (syntax args)))))))))))

(define gensym
  (let ((n -1))
    (lambda ()
      (set! n (+ n 1))
        (string-append "gensym-"
          (number->string n))))))

(define (box v) (vector v))
(define (unbox box) (vector-ref box 0))
(define (box! box v) (vector-set! box 0 v))

Pages: 1 2 3 4 5 6 7 8 9 10

3 Responses to “Chez Scheme Setup”

  1. programmingpraxis said

    My apologies; the formatting got really messed up. I’ll work on fixing through the day today.

  2. chaw said

    I think the pairing heap implementation will not scale to beyond stack limits since it uses non-tail recursion. An easy fix would be to replace the recursive calls in pq-merge-pairs with a fold of pq-merge on pre-paired arguments.

  3. […] There are several pattern-matching libraries available for Scheme, but they are rather heavy (the one I use, by Friedman, Hilsdale and Dybvig, is over six hundred lines of code). Our Standard Prelude has a […]

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: