#lang scheme/base

(require scheme/list
         (only-in (lib "1.ss" "srfi")
                  reverse! zip unzip1 unzip2 (remove removef)
                  delete-duplicates! concatenate any iota
                  alist-cons break cons* delete-duplicates every fold-right reduce find
                  lset-difference lset-union pair-fold-right unfold span take take-while
                  delete drop fold pair-fold delete! list-index
                  )
         (lib "26.ss" "srfi")
         (lib "2.ss" "srfi")
         (only-in (lib "13.ss" "srfi")
                  string-join string-trim string-trim-right string-trim-both
                  string-reverse string-reverse!)
         (lib "pregexp.ss")
         
         mzlib/defmacro
         (for-syntax scheme/base)
         scheme/match
         (lib "pretty.ss")
         (lib "unit.ss")

         (only-in  file/md5 md5)
         
         )

(provide first
         second
         rest
         empty?
         sort
         vector-for-each
         vector-list-map
         map-i
         for-each-i
         replace-i
         transform-i
         iota
         zip
         unzip1
         unzip2
         concatenate
         take
         take-while
         take-up-to
         drop
         drop-up-to
         partition
         span
         break
         safe-list-ref
         last
         last-pair
         length=
         length>
         assoc-val
         alist-key-filter
         repeat-thunk-in-list
         cut
         cute
         cross
         filter
         filter-map
         append-map
         removef
         delete
         delete!
         delete-duplicates
         delete-duplicates!
         find
         any
         every
         hash
         map-hash
         sub-hash-set!
         hash-exists?
         hash-keys
         hash-singleton-value
         hash-filter-map
         hash-hash-map
         hash-find
         alist->hash
         bucketed-hash-add!
         fold ;(iterative-style)
         fold-right ;(recursive-style)
         reduce
         reduce-right-result
         pair-fold
         pair-fold-right
         file-line-fold
         unfold
         cons*
         cons-to-end
         listify
         alist-cons
         alist-merge
         receive
         list-join
         list-index
         
         aif
         awhen
         aand
         and-let*
         
         pregexp-split
         pregexp-match
         pregexp-match-positions
         pregexp-replace
         pregexp-replace*
         pregexp-replace-many
         regexp-replace-in-list*
         
         string-join
         string-ellide
         capitalize-word
         string-trim
         string-trim-right
         string-trim-both
         string-reverse
         string-reverse!
         ->string
         
         pretty-print
         pretty-string
         
         lset-difference
         lset-union
         
         random-choice
         random-choice-and-remove
         random-sub-list
         random-key-string
         
         e
         round-k
         
         show
         prn
         
         (all-from-out scheme/match)
         
         splice-if
         asplice-if

         call-with-keyword-override
         make-recursive-keyword-version-of-fn

         max-f
         max-f-elt

         sync-on-lock
         make-lock

         md5-string
         )

(define (random-choice lst)
  (list-ref lst (random (length lst))))

(define (random-sub-list lst)
  (cond ((empty? lst) '())
        ((= (random 2) 0) (cons (first lst) (random-sub-list (rest lst))))
        (else (random-sub-list (rest lst)))))

(define (repeat-thunk-in-list thunk n)
  (let ((result '()))
    (let lp ((n n))
      (if (zero? n) result (begin (set! result (cons (thunk) result)) (lp (- n 1)))))))

(define random-key-string
  (let* ((choices '("b" "c" "d" "f" "g" "h" "j" "k" "m" "n" "p" "q" "r" "s" "t" "u" "v"
                    "x" "y" "z" "2" "3" "4" "5" "6" "7" "8" "9"))
         (len (length choices)))
    (lambda (key-len) (apply string-append (repeat-thunk-in-list
                                            (lambda () (list-ref choices (random len)))
                                            key-len)))))

(define (length= lst n)
  (= (length lst) n))

(define (length> lst n)
  (> (length lst) n))

(define-syntax show
  (syntax-rules ()
    ((_ expr)
     (let ((val expr))
       (display (format "Expr ~A => ~A\n" 'expr val))
       val))))

;; like show, but return "" instead of the value computed; also takes any number of
;; expressions; useful in web debugging because the return value ("") won't affect the
;; page if used.
(define-syntax prn
  (syntax-rules ()
    ((_ expr ...)
     (begin (show expr) ...
            "You are trying to use the return value from the prn function.  Bad you."))))

;; returns VAL X LST
(define (random-choice-and-remove lst)
  (let ((to-go (random (length lst)))
        (result '()))
    (let lp ((i 0) (lst lst))
      (if (= i to-go)
          (values (first lst) (append (reverse! result) (rest lst)))
          (begin (set! result (cons (first lst) result))
                 (lp (+ i 1) (rest lst)))))))

(define-syntax receive
  (syntax-rules ()
    ((_ (var ...) values-expr body ...)
     (let-values (((var ...) values-expr)) body ...))))

(define (map-i f . lsts)
  (let lp ((i 0) (lst-ptrs lsts))
    (if (null? (first lst-ptrs))
        '()
        (cons (apply f i (map first lst-ptrs))
              (lp (+ i 1) (map rest lst-ptrs))))))

(define (replace-i lst i new-elt)
  (transform-i lst i (lambda (x) new-elt)))

(define (transform-i lst i f)
  (map-i (lambda (j elt) (if (= j i) (f elt) elt)) lst))

(define-syntax hash
  (syntax-rules (=)
    ((_ (key = val) ...)
     (let ((ht (make-hash)))
       (hash-set! ht `key val) ...
       ht))))

(define (alist->hash alist)
  (let ((ht (make-hash)))
    (for-each (match-lambda ((list-rest k v) (hash-set! ht k v))) alist)
    ht))

(define (vector-for-each fn . vs)
  (let ((len (vector-length (first vs))))
    (let lp ((i 0))
      (if (>= i len)
          'done
          (begin (apply fn (map (lambda (v) (vector-ref v i)) vs))
                 (lp (+ 1 i)))))))

(define (vector-for-each-i fn . vs)
  (let ((len (vector-length (first vs))))
    (let lp ((i 0))
      (if (>= i len)
          'done
          (begin (apply fn i (map (lambda (v) (vector-ref v i)) vs))
                 (lp (+ 1 i)))))))

(define (vector-list-map fn . vs)
  (let ((len (vector-length (first vs))))
    (let lp ((i 0))
      (if (>= i len)
          '()
          (cons (apply fn (map (lambda (v) (vector-ref v i)) vs))
                (lp (+ 1 i)))))))

;; mutates starting-vector
(define (make-counter! starting-vector ending-vector)
  (let ((len (vector-length starting-vector)))
    ;; returns #f when done
    (lambda ()
      (let lp ((i (- len 1)))
        (and (>= i 0)
             (let ((cur (+ 1 (vector-ref starting-vector i))))
               (vector-set! starting-vector i cur)
               (if (<= cur (vector-ref ending-vector i))
                   starting-vector
                   (begin (vector-set! starting-vector i 0)
                          (lp (- i 1))))))))))

(define (for-each-i fn . lists)
  (let lp ((i 0) (lists lists))
    (if (null? (first lists))
        'done
        (begin (apply fn i (map first lists))
               (lp (+ i 1) (map rest lists))))))

;; can't this be shorter?
(define (cross . lsts)
  (if (= (length lsts) 1)
      (zip (first lsts))
      (let ((rst (apply cross (rest lsts))))
        (append-map (lambda (next)
                      (map (lambda (cons-result)
                             (cons next cons-result))
                           rst))
                    (first lsts)))))

;; fn : elt -> (VALUES k v)
(define (map-hash fn lst)
  (let ((ht (make-hash)))
    (for-each (lambda (elt) (receive (k v) (fn elt) (hash-set! ht k v)))
              lst)
    ht))

(define (hash-exists? ht k)
  (let* ((does-exist #t)
         (failure-thunk (lambda () (set! does-exist #f))))
    (hash-ref ht k failure-thunk)
    does-exist))

(define (hash-keys ht)
  (hash-map ht (lambda (k v) k)))

(define (hash-singleton-value ht)
  (if (= (hash-count ht) 1)
      (hash-iterate-value ht (hash-iterate-first ht))
      (error (format "Exactly one value expected in hash table ~A." ht))))

;; for creating hash-tables within hash-tables, when the outer-key might not exist
;; (in this case, we create a fresh sub-hash-table)
(define (sub-hash-set! outer-ht outer-key inner-key val)
  (let ((has-outer-key (hash-exists? outer-ht outer-key)))
    (unless has-outer-key
      (hash-set! outer-ht outer-key (make-hash)))
    (let ((inner-ht (hash-ref outer-ht outer-key)))
      (hash-set! inner-ht inner-key val))))

(define (hash-filter-map ht fn)
  (removef not (hash-map ht fn)))

;; returns a new hash-table:
(define (hash-hash-map ht fn)
  (let ((fresh-ht (make-hash)))
    (hash-for-each ht (lambda (k v) (hash-set! fresh-ht k (fn k v))))
    fresh-ht))

;; fn : key X val -> #f | alpha
(define (hash-find ht fn)
  (aand (find (lambda (k) (fn k (hash-ref ht k))) (hash-keys ht))
        (hash-ref ht it)))

(define (bucketed-hash-add! bht key val)
  (hash-set! bht key (cons val (hash-ref bht key '()))))

;; f : line-str X acc -> acc'
(define (file-line-fold f initial file-name)
  (with-input-from-file file-name
    (lambda ()
      (let lp ((putative-line (read-line)) (acc initial))
        (if (eof-object? putative-line)
            acc
            (lp (read-line) (f putative-line acc)))))))

(define-macro (aif a b c)
  `(let ((it ,a))
     (if it ,b ,c)))

(define-macro (awhen test . body)
  `(let ((it ,test))
     (if it (begin ,@body) 'done)))

(define-macro (aand . args)
  (if (null? args)
      #t
      (if (null? (cdr args))
          (car args)
          `(let ((it ,(car args)))
             (if it (aand ,@(cdr args)) #f)))))

(define (pretty-string v)
  (let ((p (open-output-string)))
    (pretty-print v p)
    (get-output-string p)))

;;
;; pregexp-replace-many
;;
;; E.g.,
;; (pregexp-replace-many some-str
;;                       ("\n" => " ")
;;                       ("foo" => "bar"))
;;
(define-syntax pregexp-replace-many
  (syntax-rules (=>)
    ((_ str (pattern => replacement) ...)
     (let ((result str))
       (set! result (pregexp-replace* pattern result replacement))
       ...
       result))))

;;
;; regexp-replace-in-list*
;;
;; like pregexp-replace* but the return result is a list of strings and alphas,
;; where alpha is the return type of your function match->xexpr.
;; Unlike pregexp-replace*, the third argument must be a function, and it must
;; take one argument (thus the regexp must only match one thing).
;;
;; You can optionally provide a 4th arg function which will be applied to segments
;; of the given str that don't match.  This can be useful when you have more than
;; one potential transform to apply to a string.
;;
;; Example: (regexp-replace-in-list* "ab" "abbracadabra" (lambda (match) "!"))
;; ==> ("!" "bracad" "!" "ra")
;;
;; Note: this is regexp, not pregexp (Perl regexp), so it's missing some features.
;;  Pregexp "uses { and } bounded repetition and uses \ for meta-characters both
;;  inside and outside of ranges."
;;
(define (regexp-replace-in-list* regexp str match->xexpr
                                  (non-match->xexpr (lambda (x) x)))
  (let lp ((matches (regexp-match-positions* regexp str))
           (idx 0))
    (if (empty? matches)
        (let ((len (string-length str)))
          (if (= idx len)
              (list)
              (list (non-match->xexpr (substring str idx (string-length str))))))
        (let* ((from-idx (caar matches))
               (to-idx (cdar matches))
               (left-str (substring str idx from-idx))
               (matched-str (substring str from-idx to-idx))
               (result (match->xexpr matched-str)))
          (append (if (string=? "" left-str)
                      (list result)
                      (list (non-match->xexpr left-str) (match->xexpr matched-str)))
                  (lp (rest matches) to-idx))))))

(define (assoc-val key alist (missing-val #f))
  (let ((lookup (assoc key alist)))
    (if lookup (cdr lookup) missing-val)))

;; returns an alist where keys are eq are "merged".  alists further to the right
;; overshadow those to the left. duplicate keys are removed.
(define (alist-merge . alists)
  (delete-duplicates! (concatenate (reverse alists))
                      (lambda (pair1 pair2) (eq? (car pair1) (car pair2)))))

;;
;; list-join
;;
;; (-> (listof any?) any? (listof any?))
;;
;; Analagous to string-join.
;; E.g., (list-join '(a b c) '(x x)) => (a (x x) b (x x) c)
;;
(define (list-join lst joiner)
  (concatenate (pair-fold-right (lambda (pair acc)
                                  (let ((elt (car pair)))
                                    (cons (if (empty? (cdr pair))
                                              (list elt)
                                              (list elt joiner))
                                          acc)))
                                '() lst)))

(define (alist-key-filter fn alist)
  (filter (match-lambda ((list-rest k v) (fn k))) alist))

(define (cons-to-end elt lst)
  (append lst (list elt)))

(define (e format-str . args)
  (error (apply format format-str args)))

(define (take-up-to lst n)
  (if (or (zero? n) (empty? lst))
      '()
      (cons (first lst) (take-up-to (rest lst) (- n 1)))))

(define (drop-up-to lst n)
  (if (or (zero? n) (empty? lst))
      lst
      (drop-up-to (rest lst) (- n 1))))

;; usage: inside a backquote, ,@(splice-if TEST VAL) or ,@(splice-if TEST-AND-VAL)
(define-syntax splice-if
  (syntax-rules ()
    ((_ test val)
     (if test (list val) '()))
    ((_ test)
     (let ((t test))
       (if t (list t) '())))))

(define-macro (asplice-if test val)
  `(let ((it ,test))
     (splice-if it val)))

;; returns a string of at most n chars.  Uses ellipsis if it has to chop.
(define (string-ellide str n)
  (let ((len (string-length str)))
    (if (<= len (- n 3))
        str
        (string-append (substring str 0 (- n 4)) "..."))))

;; if idx < 0 then returns 0th elt
;; if idx > len-1, then returns (len-1)th elt
;; it's still an error to use on an empty list.
(define (safe-list-ref lst idx)
  (if (< idx 0)
      (first lst)
      (let ((len (length lst)))
        (if (>= idx len)
            (list-ref lst (- len 1))
            (list-ref lst idx)))))

;; XXX should use srfi 13 version of string-upcase, but can't figure out how to get the
;; conflicts working with the mzscheme version.
(define (capitalize-word str)
  (let ((chars (string->list str)))
    (list->string (cons (char-upcase (first chars)) (rest chars)))))

(define (make-recursive-keyword-version-of-fn fn recur-kw-str)
  (make-keyword-procedure
   (lambda (kws kw-vals . reg-args)
     (define recur
       (make-keyword-procedure
        (lambda (override-kws override-kw-vals . override-reg-args)
          (call-with-keyword-override fn
                                      kws kw-vals
                                      (cons (string->keyword recur-kw-str)
                                            override-kws)
                                      (cons recur override-kw-vals)
                                      (if (empty? override-reg-args)
                                          reg-args
                                          override-reg-args)))))
     (recur))))

;; call fn with original kws/kw-vals except override with new kws/kw-vals:
(define (call-with-keyword-override fn
                                    original-kws original-kw-vals
                                    new-kws new-kw-vals
                                    reg-args)
  (receive (kws kw-vals)
      (unzip2 (sort (lset-union (lambda (k1.v1 k2.v2) (eq? (car k1.v1) (car k2.v2)))
                                (zip new-kws new-kw-vals)
                                (zip original-kws original-kw-vals))
                    (lambda (k1.v1 k2.v2) (keyword<? (car k1.v1) (car k2.v2)))))
    (keyword-apply fn kws kw-vals reg-args)))

;; round n to k places to the right of the decimal
(define (round-k n k)
  (let ((dec-mover (expt 10 k)))
    (/ (round (* dec-mover n)) dec-mover)))

(define (->string thing)
  (cond ((string? thing) thing)
        ((symbol? thing) (symbol->string thing))
        (else (e "Don't know how to convert '~A' into a string."))))

;; the first invocation of f looks like (f init (first lst))
;; cannot
(define (reduce-right-result kons init lst)
  (if (null? lst)
      init
      (let lp ((lst (rest lst)) (acc (kons (first lst) init)))
        (if (null? lst)
            acc
            (lp (rest lst) (kons (first lst) acc))))))

;;
;; max-f
;;
;; find the elt in lst which has the highest value of (f elt) which is greater than
;; init-max, and return that max value.
;;
;;
(define (max-f init-max f lst)
  (let ((m init-max))
    (for-each (lambda (elt) (let ((v (f elt))) (when (> v m) (set! m v))))
              lst)
    m))

;;
;; max-f-elt
;;
;; like max-f, but returns the element instead of the max value.
;;
(define (max-f-elt init-max f lst)
  (let ((m init-max)
        (m-elt 'dummy))
    (for-each (lambda (elt) (let ((v (f elt))) (when (> v m) (set! m v) (set! m-elt elt))))
              lst)
    m-elt))

(define (listify x)
  (if (list? x) x (list x)))

(define-syntax sync-on-lock
  (syntax-rules ()
    ((_ lock body ...)
     (begin (semaphore-wait lock)
            (let ((val (begin body ...)))
              (semaphore-post lock)
              val)))))

(define (make-lock)
  (make-semaphore 1))

(define (md5-string str)
  (bytes->string/utf-8 (md5 (string->bytes/utf-8 str))))

;; pretty printing:
(print-hash-table #t)
(print-struct #t)