;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                      ;;
;;  http://www.megabaud.fi/~karttu/matikka/Schemuli/lstfuns1.scm        ;;
;;  - Often needed list functions and such.                             ;;
;;                                                                      ;;
;;  (Schemuli stands for the "Useful Library for Scheme" and "matikka"  ;;
;;   is a certain kind of fish, believe it or not).                     ;;
;;                                                                      ;;
;;  Coded by Antti Karttunen (my_firstname.my_surname@iki.fi), 2002--   ;;
;;  Last edited Dec 22 2008.                                            ;;
;;                                                                      ;;
;;  This Scheme-code is in Public Domain and runs (at least)            ;;
;;  in MIT Scheme Release 7.6.0, for which one can find documentation   ;;
;;  and the pre-compiled binaries (for various OS's running in          ;;
;;  Intel x86 architecture) under the URL:                              ;;
;;  http://www.swiss.ai.mit.edu/projects/scheme/                        ;;
;;                                                                      ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; From http://www.swiss.ai.mit.edu/projects/scheme/documentation/user_5.html
;;
;; If you redefine some global name in your code, for example, car, cdr
;; and cons, you should indicate it in the declaration as:
;; (declare (usual-integrations car cdr cons))

;; (Beware of using an argument name like list in the function definitions?)

(declare (usual-integrations))


;;
;; Compile as:
;;
;; (cf "c:\\matikka\\Schemuli\\lstfuns1" "c:\\matikka\\Schemuli\\")
;; 

(define (car* p) (if (pair? p) (car p) p))
(define (cdr* p) (if (pair? p) (cdr p) p))

(define vector-set-and-return-value!
        (lambda (vec ind val) (vector-set! vec ind val) val)
)


(define (add-to-vec! vec n what)
   (let ((newvec (if (>= n (vector-length vec)) (vector-grow vec (1+ n)) vec)))
      (vector-set! newvec n what)
      newvec
   )
)

(define (incr-num-vector! vec n)
   (let ((old (vector-ref vec n)))
      (cond ((not (number? old)) (vector-set! vec n 1))
            (else (vector-set! vec n (1+ old)))
      )
   )
)


(define (collect-non-zero-values-from-num-vector vec) ;; to an association list
   (let loop ((i (-1+ (vector-length vec))) (a (list)))
       (cond ((negative? i) a)
             (else
               (let ((n (vector-ref vec i)))
                  (cond ((or (not (number? n)) (zero? n)) (loop (-1+ i) a))
                        (else (loop (-1+ i) (cons (cons i n) a)))
                  )
               )
             )
       )
   )
)



;; Unnecessary, use vector-fill!
;; (define (fill-vec-with! vec what)
;;   (let loop ((n (vector-length vec)))
;;      (cond ((zero? n) vec)
;;            (else (vector-set! vec (-1+ n) what)
;;                  (loop (-1+ n))
;;            )
;;      )
;;   )
;; )

(define (bisect lista parity) ;; Parity is 0 or 1.
   (let loop ((lista lista) (i 0) (z (list)))
        (cond ((null? lista) (reverse! z))
              ((eq? i parity)
                    (loop (cdr lista) (modulo (1+ i) 2) (cons (car lista) z))
              )
              (else (loop (cdr lista) (modulo (1+ i) 2) z))
        )
   )
)



(define (distinct-elems lista)
   (if (not (pair? lista))
       0
       (let loop ((n 0)
                  (lista lista)
                  (prev (not (car lista)))
                 )
           (cond ((not (pair? lista)) n)
                 ((equal? (car lista) prev) (loop n (cdr lista) prev))
                 (else                      (loop (1+ n) (cdr lista) (car lista)))
           )
       )
   )
)


(define (multiplicities lista) ;; Of numeric elements.
       (let loop ((mults (list))
                  (lista lista)
                  (prev #f)
                 )
           (cond ((not (pair? lista)) (reverse! mults))
                 ((equal? (car lista) prev)
                     (set-car! mults (+ 1 (car mults)))
                     (loop mults (cdr lista) prev)
                 )
                 (else
                   (loop (cons 1 mults) (cdr lista) (car lista))
                 )
           )
       )
)


(define (uniq lista) ;; Assumed to be sorted already with (sort lista <)
   (let loop ((lista lista) (z (list)))
        (cond ((null? lista) (reverse! z))
              ((and (pair? z) (equal? (car z) (car lista)))
                    (loop (cdr lista) z)
              )
              (else (loop (cdr lista) (cons (car lista) z)))
        )
   )
)

(define (multiset->countpairs mset)
  (let ((sorted (sort mset <)))
    (map cons (multiplicities sorted) (uniq sorted))
  )
)

(define reversed_iota
  (lambda (n)
      (if (zero? n) (list)
          (cons n (reversed_iota (- n 1)))
      )
  )
)

(define iota (lambda (n) (reverse! (reversed_iota n))))

(define (iota0 upto_n)
   (let loop ((n upto_n) (result (list)))
      (cond ((zero? n) (cons 0 result))
            (else (loop (- n 1) (cons n result)))
      )
   )
)

(define (pos-of-first-matching lista pred?)
   (let loop ((lista lista) (i 0))
     (cond ((null? lista) #f)
           ((pred? (car lista)) i)
           (else (loop (cdr lista) (1+ i)))
     )
   )
)

(define (nthmemq elem lista)
   (let loop ((lista lista) (i 0))
     (cond ((null? lista) #f)
           ((eq? (car lista) elem) i)
           (else (loop (cdr lista) (1+ i)))
     )
   )
)


(define (nthcdrmemq sublist lista)
   (let loop ((lista lista) (i 0))
     (cond ((null? lista) #f)
           ((eq? lista sublist) i)
           (else (loop (cdr lista) (1+ i)))
     )
   )
)


(define (positions n a)
  (let loop ((b (list)) (a a) (i 0))
    (cond ((null? a) (reverse! b))
          ((= (car a) n) (loop (cons i b) (cdr a) (1+ i)))
          (else (loop b (cdr a) (1+ i)))
    )
  )
)

(define (DIFF a)
  (map - (cdr a) (reverse! (cdr (reverse a))))
)

(define (PARTSUMS a)
  (cdr (reverse! (fold-left (lambda (psums n) (cons (+ n (car psums)) psums)) (list 0) a)))
)

(define attach! ; Borrowed from Franz lisp, is like destructive cons.
  (lambda (elem lista)
     (set-cdr! lista (cons (car lista) (cdr lista)))
     (set-car! lista elem)
     lista
  )
)


(define (pop! lista)
  (let ((topmost (car lista)))
    (cond ((pair? (cdr lista))
                (set-car! lista (cadr lista))
                (set-cdr! lista (cddr lista))
          )
    )
    topmost
  )
)

;; Convert (a . (b . rest)) --> ((a . b) . rest)
;; with no cons cells wasted.

(define (cons2top! stack)
  (let ((ex-cdr (cdr stack)))
      (set-cdr! stack (car ex-cdr))
      (set-car! ex-cdr stack)
      ex-cdr
  )
)


(define (flip!topmost stack)
  (let* ((topmost (car stack))
         (ex-cdr (cdr topmost))
        )
      (set-cdr! topmost (car topmost))
      (set-car! topmost ex-cdr)
      stack
  )
)

;; (list-n-from-top 0 stack) pushes () to top of stack.
;; (list-n-from-top 1 stack) replaces the top element with its list:ed version,
;; etc.
(define (list-n-from-top n stack)
  (cons (list-head stack n) (nthcdr n stack))
)


(define (count-pars a)
    (cond ((not (pair? a)) 0)
          (else (+ 1 (count-pars (car a)) (count-pars (cdr a))))
    )
)

(define (max* a b)
  (cond ((and (number? a) (number? b)) (max a b))
        ((number? a) a)
        ((number? b) b)
        (else #f)
  )
)

(define (max-in-tree bt)
     (cond ((not (pair? bt)) bt)
           (else (max* (max-in-tree (car bt))
                       (max-in-tree (cdr bt))
                 )
           )
     )
)


(define (copy-tree bt)
  (cond ((not (pair? bt)) bt)
        (else (cons (copy-tree (car bt))
                    (copy-tree (cdr bt)))
        )
  )
)


(define (nthcdr n lista)
  (if (or (zero? n) (null? lista))
      lista
      (nthcdr (- n 1) (cdr lista))
  )
)


;; For testing whether we have an identity permutation or not.
(define (first-dislocated lista)
   (let loop ((lista lista) (i 0))
     (cond ((null? lista) lista)
           ((not (eq? (car lista) i)) lista)
           (else (loop (cdr lista) (1+ i)))
     )
   )
)

(define (non-false-positions lista)
  (let loop ((lista lista) (a (list)) (i 0))
     (cond ((null? lista) (reverse! a))
           ((car lista) (loop (cdr lista) (cons i a) (1+ i)))
           (else (loop (cdr lista) a (1+ i)))
     )
  )
)

;; See http://pobox.com/~oleg/ftp/papers/XML-parsing-talk.ps.gz, page 45/49.
;;
;;   Note that
;;
;;   foldr (x seed -> foldl (flip (:)) seed x) []
;;
;;   is an efficient implementation of
;;
;;   concat . map reverse
;;
;; i.e. (apply append! (map reverse s))

(define (reverse-sublists-and-concat s)
  (fold-right (lambda (a b)
                 (fold-left (lambda (x y) (cons y x)) b a)
              )
              '()
              s
  )
)

;; Why not use reduce or fold-left or fold-right here?
;; Because I didn't know about them at the time I wrote these.
;; And then I would need to generate the list of indices
;; first, which is wasteful. But for Sum over divisors
;; it is nice.

;; Implement sum_{i=lowlim..uplim} intfun(i)
(define (add intfun lowlim uplim)
   (let sumloop ((i lowlim) (res 0))
      (cond ((> i uplim) res)
            (else (sumloop (1+ i) (+ res (intfun i))))
      )
   )
)

(define (mul intfun lowlim uplim)
   (let multloop ((i lowlim) (res 1))
      (cond ((> i uplim) res)
            (else (multloop (1+ i) (* res (intfun i))))
      )
   )
)


(define (collect-intfun-values-to-list intfun lowlim uplim)
  (let loop ((z (list)) (i uplim))
         (cond ((< i lowlim) z)
               (else (loop (cons (intfun i) z) (-1+ i)))
         )
  )
)

;; Stupid:
;; (define (same-intfuns? fun1 fun2 lowlim uplim) ;; Check superficially.
;;   (zero? (add (lambda (n) (abs (- (fun1 n) (fun2 n)))) lowlim uplim))
;; )

(define (same-intfuns? fun1 fun2 uplim)
   (let checkloop ((i 1))
      (cond ((> i uplim) #t) ;; superficially, up to n uplim, yes.
            ((not (equal? (fun1 i) (fun2 i))) i) ;; return first i where they differ.
            ((= 0 (modulo i 16384)) (write i) (newline) (flush-output) (checkloop (1+ i)))
            (else (checkloop (1+ i)))
      )
   )
)


(define (print-fixed-points outfile fun1 uplim)
  (call-with-output-file outfile
    (lambda (out)
      (let checkloop ((i 1))
        (cond ((> i uplim) #t) ;; superficially, up to n uplim, yes.
              ((= i (fun1 i))
                 (write 'fixed:) (write i) (newline) (flush-output)
                 (write i out) (newline out) (flush-output out) (checkloop (1+ i))
              )
              ((= 0 (modulo i 262144))
                 (write 'running:) (write i) (newline) (flush-output) (checkloop (1+ i)))
              (else (checkloop (1+ i)))
        )
      )
    )
  )
)

(define (count-the-occurrences intfun what lowlim uplim)
   (let cntloop ((i lowlim) (res 0))
      (cond ((> i uplim) res)
            (else (cntloop (1+ i) (+ res (if (= what (intfun i)) 1 0))))
      )
   )
)

(define (compose-funlist funlist)
 (cond ((null? funlist) (lambda (x) x))
       (else (lambda (x) ((car funlist) ((compose-funlist (cdr funlist)) x))))
 )
)

(define (compose-funs . funlist)
 (cond ((null? funlist) (lambda (x) x))
       (else (lambda (x) ((car funlist) ((apply compose-funs (cdr funlist)) x))))
 )
)


(define (compose-fun-to-nth-power fun n)
 (cond ((zero? n) (lambda (x) x))
       (else (lambda (x) (fun ((compose-fun-to-nth-power fun (- n 1)) x))))
 )
)

;; Semantically
;; ((compose-fun-to-nth-power fun n) x) =  (apply-n-times fun n x)
;; although this should be much more practical:
(define (apply-n-times fun n x)
    (cond ((zero? n) x)
          (else (apply-n-times fun (-1+ n) (fun x)))
    )
)