270 lines
8.0 KiB
Scheme
270 lines
8.0 KiB
Scheme
|
|
(module util (lib "mrflow.ss" "mrflow")
|
|
(require (prefix list: (lib "list.ss"))
|
|
(lib "pretty.ss")
|
|
(lib "class.ss")
|
|
(prefix cst: "constants.ss"))
|
|
|
|
(provide (all-defined))
|
|
|
|
;;
|
|
;; Number functions
|
|
;;
|
|
(define natural? (lambda (n) (and (integer? n) (>= n 0))))
|
|
|
|
|
|
;;
|
|
;; List functions
|
|
;;
|
|
(define length-one?
|
|
(lambda (x) (and (pair? x) (null? (cdr x)))))
|
|
|
|
(define nonempty-list-of?
|
|
(lambda (p) (lambda (xs) (and (pair? xs) (andmap p xs)))))
|
|
|
|
(define unfold-onto
|
|
(lambda (p f g seed onto)
|
|
(if (p seed) onto
|
|
(cons (f seed) (unfold-onto p f g (g seed) onto)))))
|
|
|
|
(define unfold
|
|
(lambda (p f g seed)
|
|
(unfold-onto p f g seed '())))
|
|
|
|
;; int -> list int
|
|
(define iota
|
|
(lambda (n)
|
|
(unfold (lambda (x) (= x n)) (lambda (x) x) add1 0)))
|
|
|
|
(define min-list-numbers
|
|
(let ([remove-duplicates ;; remove duplicate numbers from a sorted list
|
|
(lambda (xs) ;; of numbers, returned list is reversed
|
|
(if (null? xs) '()
|
|
(let loop ((xs (cdr xs)) (acc (list (car xs))))
|
|
(if (null? xs) acc
|
|
(if (< (car xs) (car acc))
|
|
(loop (cdr xs) (cons (car xs) acc))
|
|
(loop (cdr xs) acc))))))])
|
|
(lambda (nums)
|
|
(remove-duplicates (list:sort nums >)))))
|
|
|
|
(define/contract lol->vov ((listof (listof any/c)) . -> . vector?)
|
|
(lambda (xss) (list->vector (map list->vector xss))))
|
|
|
|
(define map2deep
|
|
(lambda (f xss)
|
|
(map (lambda (xs) (map f xs)) xss)))
|
|
|
|
(define no-duplicates?/c
|
|
(flat-named-contract "List without duplicates"
|
|
(lambda (xs)
|
|
(let ([tbl (make-hash-table)])
|
|
(let/ec return-with
|
|
(for-each (lambda (x)
|
|
(when (hash-table-get tbl x cst:thunk-false)
|
|
(return-with #f))
|
|
(hash-table-put! tbl x #t))
|
|
xs)
|
|
#t)))))
|
|
|
|
;;
|
|
;; Vector functions
|
|
;;
|
|
(define foldr-vector
|
|
(lambda (f init v)
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length v)) init
|
|
(f (vector-ref v i) (loop (add1 i)))))))
|
|
|
|
(define interval->list
|
|
(lambda (v lo hi)
|
|
(let loop ([i lo])
|
|
(if (= i hi) '()
|
|
(cons (vector-ref v i) (loop (add1 i)))))))
|
|
|
|
(define list->immutable-vector
|
|
(lambda xs
|
|
(apply vector-immutable xs)))
|
|
|
|
(define/contract map-vector ((any/c . -> . any) vector? . -> . vector?)
|
|
(lambda (f v)
|
|
(let* ([len (vector-length v)]
|
|
[new-v (make-vector len #f)])
|
|
(let loop ([i 0])
|
|
(when (< i len)
|
|
(vector-set! new-v i (f (vector-ref v i)))
|
|
(loop (add1 i))))
|
|
new-v)))
|
|
|
|
(define/contract map-vector-of-vector ((any/c . -> . any) (vectorof vector?) . -> . (vectorof vector?))
|
|
(lambda (f vov)
|
|
(map-vector (lambda (v) (map-vector f v)) vov)))
|
|
|
|
(define/contract for-each-vector ((any/c . -> . any) vector? . -> . void?)
|
|
(lambda (f v)
|
|
(let ([len (vector-length v)])
|
|
(let loop ([i 0])
|
|
(when (< i len)
|
|
(f (vector-ref v i))
|
|
(loop (add1 i)))))
|
|
cst:void))
|
|
|
|
; Replace each element e in a vector with (f e)
|
|
(define/contract for-each-vector! ((any/c . -> . any) vector? . -> . vector?)
|
|
(lambda (f v)
|
|
(let ([len (vector-length v)])
|
|
(let loop ([i 0])
|
|
(when (< i len)
|
|
(vector-set! v i (f (vector-ref v i)))
|
|
(loop (add1 i)))))
|
|
v))
|
|
|
|
(define/contract for-each-vov ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . void?)
|
|
(lambda (f vov)
|
|
(for-each-vector (lambda (v) (for-each-vector f v) v) vov)))
|
|
|
|
; Replace each element in a vector of vectors with (f e)
|
|
(define/contract for-each-vov! ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . any)
|
|
(lambda (f vov)
|
|
(for-each-vector! (lambda (v) (for-each-vector! f v) v) vov)
|
|
vov))
|
|
|
|
(define vector-of?
|
|
(lambda (pred v)
|
|
(let/ec escape
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length v)) #t
|
|
(if (pred (vector-ref v i))
|
|
(loop (add1 i))
|
|
(escape #f)))))))
|
|
|
|
(define vector-of-vector-of?
|
|
(lambda (pred vov)
|
|
(vector-of? (lambda (v) (vector-of? pred v)) vov)))
|
|
|
|
(define vector-has?
|
|
(lambda (pred v)
|
|
(let/ec escape
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length v)) #f
|
|
(if (pred (vector-ref v i))
|
|
(escape #t)
|
|
(loop (add1 i))))))))
|
|
|
|
(define vector-of-vector-has?
|
|
(lambda (pred vov)
|
|
(vector-has? (lambda (v) (vector-has? pred v)) vov)))
|
|
|
|
|
|
;;
|
|
;; Hash functions
|
|
;;
|
|
|
|
(define hash-table-size
|
|
(lambda (h)
|
|
(let ([size 0])
|
|
(hash-table-for-each h (lambda (_ _2) (set! size (add1 size))))
|
|
size)))
|
|
|
|
(define hash-table-empty?
|
|
(lambda (h)
|
|
(let/ec escape
|
|
(hash-table-for-each h (lambda (k v) (escape #f)))
|
|
#t)))
|
|
|
|
(define/contract hash-table-has-key? (hash-table? any/c . -> . boolean?)
|
|
(lambda (hash-table key)
|
|
(if (hash-table-get hash-table key cst:thunk-false) #t #f)))
|
|
|
|
;; (hash-table key (list value)) key value -> (hash-table key (list value))
|
|
(define/contract hash-table-prepend! (hash-table? any/c any/c . -> . any)
|
|
(lambda (hash-table key value)
|
|
(hash-table-put! hash-table key
|
|
(if (hash-table-has-key? hash-table key)
|
|
(cons value (hash-table-get hash-table key
|
|
(lambda () (error 'hash-table-prepend! "Could not prepend"))))
|
|
(list value)))))
|
|
|
|
;;
|
|
;; Function functions
|
|
;;
|
|
(define (curry f)
|
|
(lambda (x) (f x)))
|
|
|
|
;;
|
|
;; Boolean functions
|
|
;;
|
|
(define true?
|
|
(lambda (x) (eq? x #t)))
|
|
|
|
;;
|
|
;; Random functions
|
|
;;
|
|
|
|
(define/contract numberify-symbol (symbol? integer? . -> . symbol?)
|
|
(lambda (sym x)
|
|
(string->symbol (string-append (symbol->string sym) ":" (number->string x)))))
|
|
|
|
(define/contract numberify-list ((cons/c symbol? (listof any/c)) integer? . -> . (cons/c symbol? (listof any/c)))
|
|
(lambda (syms x)
|
|
(cons (numberify-symbol (car syms)) (cdr syms))))
|
|
|
|
(define/contract pretty-error (symbol? any/c . -> . any)
|
|
(lambda (sym v)
|
|
(let ([out (open-output-string)])
|
|
(pretty-print v out)
|
|
(error sym (get-output-string out)))))
|
|
|
|
(define andmap4-vector
|
|
(lambda (f v0 v1 v2 v3)
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length v0)) #t
|
|
(and (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
|
|
(loop (add1 i)))))))
|
|
|
|
(define andmap2-vector-interval
|
|
(lambda (f v0 v1 lo high)
|
|
(let loop ([i lo])
|
|
(if (= i high) #t
|
|
(and (f (vector-ref v0 i) (vector-ref v1 i))
|
|
(loop (add1 i)))))))
|
|
|
|
(define andmap2-vector
|
|
(lambda (f v0 v1)
|
|
(andmap2-vector-interval f v0 v1 0 (vector-length v0))))
|
|
|
|
; return #t if the p(i) = # for all i in the half-open interval lo <= i < hi
|
|
(define andmap-vector-interval
|
|
(lambda (f v0 lo high)
|
|
(let loop ([i lo])
|
|
(if (= i high) #t
|
|
(and (f (vector-ref v0 i))
|
|
(loop (add1 i)))))))
|
|
|
|
(define andmap-vector
|
|
(lambda (f v0)
|
|
(andmap-vector-interval f v0 0 (vector-length v0))))
|
|
|
|
(define ormap4-vector
|
|
(lambda (f v0 v1 v2 v3)
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length v0)) #f
|
|
(or (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
|
|
(loop (add1 i)))))))
|
|
|
|
|
|
;; Classes
|
|
|
|
(define counter%
|
|
(class object%
|
|
(init-field [start 0])
|
|
(define count start)
|
|
|
|
(define/public get
|
|
(lambda () count))
|
|
|
|
(define/public next!
|
|
(lambda () (set! count (add1 count)) count))
|
|
(super-new)))
|
|
)
|