
;; Copyright (C) 2008-2018 Tommi Höynälänmaa

;; Licensed under GNU Lesser General Public License version 3.
;; See file doc/LGPL-3.


(define-module (th-scheme-utilities stdutils)
  #:duplicates (merge-generics replace last)
  #:export (xor
             and-map?
            or-map?
            map*
            vector-map*
            my-vector-map
            vector-and-map?
            vector-or-map?
            do-assert
            do-strong-assert
            not-null?
            search
            general-search
            butlast
            read-file
            write-line
            search-for-char-to-split
            split-string
            string-contains-char?
            fold2-with-break
            not-false?
            raise-simple
            raise1
            raise2
            delete-duplicates1
            union-of-lists
            union-of-alists
            list-set-diff
            replace-list-element
            strong-assert
            make1
            make-class1
            fluid-let
            unwind-protect-local
            iterate-list
            iterate-list-with-break))


(import (rnrs base)
        (rnrs exceptions)
        (rnrs lists)
        (except (srfi srfi-1) map)
        (srfi srfi-43)
        (oop goops))


(define (xor b1 b2)
  (assert (boolean? b1))
  (assert (boolean? b2))
  (not (eq? b1 b2)))


(define (and-map? fn . lists)
  (if (apply for-all fn lists) #t #f))


(define (or-map? fn . lists)
  (if (apply exists fn lists) #t #f))

(define map* map-in-order)

(define (vector-map* fn . vectors)
  (let*
    ((count (apply min (map vector-length vectors)))
     (result (make-vector count)))
    (do ((i 0 (+ i 1))) ((>= i count) result)
      (vector-set! result i
                   (apply fn
                     ; lista vektorien i:nsistä alkoista
                     (map (lambda (v) (vector-ref v i)) vectors))))))

(define my-vector-map vector-map*)

(define (vector-and-map? fn . vectors)
  (if (apply vector-every fn vectors) #t #f))

(define (vector-or-map? fn . vectors)
  (if (apply vector-any fn vectors) #t #f))

(define (do-assert condition x-condition)
  (if (not condition)
    (begin
     (display "Assertion ")
     (display x-condition)
     (display " failed.")
     (newline)
     (raise 'assertion-failed))))

;; Strong assert is to be used when
;; the assertion checking should never be
;; switched off for optimization.
(define (do-strong-assert condition x-condition)
  (if (not condition)
    (begin
     (display "Assertion ")
     (display x-condition)
     (display " failed.")
     (newline)
     (raise 'assertion-failed))))

(define (not-null? x) (not (null? x)))

(define (do-search val lst ind)
  (cond
    ((null? lst) -1)
    ((eqv? (car lst) val) ind)
    (else (do-search val (cdr lst) (+ ind 1)))))

(define (search val lst)
  (do-search val lst 0))

(define (do-general-search val lst pred ind)
  (cond
    ((null? lst) -1)
    ((pred val (car lst)) ind)
    (else (do-general-search val (cdr lst) pred (+ ind 1)))))

(define (general-search val lst pred)
  (do-general-search val lst pred 0))

(define (butlast lst)
  (drop lst 1))

(define (read-file fl)
  (let ((result '())
        (stop #f))
    (do () (stop result)
      (let ((cur (read fl)))
        (if (eof-object? cur)
          (set! stop #t)
          (set! result (append result (list cur))))))))

(define (write-line obj . rest)
  (if (pair? rest)
    (begin
     (display obj (cadr rest))
     (newline (cadr rest)))
    (begin
     (display obj)
     (newline))))

(define (search-for-char-to-split str start char)
  (let ((len (string-length str))
        (found-index -1))
    (do ((i start (+ i 1))) ((or (>= i len) (not (eqv? found-index -1))) found-index)
      (if (eqv? (string-ref str i) char)
        (set! found-index i)))))

(define (split-string0 str separator start)
  ;; (assert (string? str))
  ;; (assert (char? separator))
  ;; (assert (integer? start))
  (cond
    ((>= start (string-length str)) '())
    ((eqv? (string-ref str start) separator)
     (cons ""
           (split-string0 str separator (+ start 1))))
    (else
     (let ((next-separator-index
            (search-for-char-to-split str start separator))
           (len (string-length str)))
       (cond
         ((= next-separator-index -1)
          (list (substring str start (string-length str))))
         ((= next-separator-index (- len 1))
          (list (substring str start next-separator-index) ""))
         (else
          (cons (substring str start next-separator-index)
                (split-string0 str separator (+ next-separator-index 1)))))))))

;; Guile procedure string-split probably makes this unnecessary.
(define (split-string str separator)
  (split-string0 str separator 0))

;; This procedure could be implemented with procedure string-index.
(define (string-contains-char? str char)
  (let ((len (string-length str))
        (found? #f))
    (do ((i 0 (+ i 1))) ((or (>= i len) found?) found?)
      (if (eqv? (string-ref str i) char)
        (set! found? #t)))))

(define (fold2-with-break proc x-init l1 l2)
  (if (not x-init)
    #f
    (if (or (null? l1) (null? l2))
      x-init
      (fold2-with-break proc
                        (proc (car l1) (car l2) x-init)
                        (cdr l1)
                        (cdr l2)))))

(define (not-false? x)
  (not (eq? x #f)))

(define raise-simple raise)

(define (raise1 s-kind al-info)
  (raise (cons s-kind al-info)))

(define (raise2 s-kind . al-info)
  (raise (cons s-kind al-info)))

(define (delete-duplicates1 lst pred-eq)
  (assert (list? lst))
  (assert (procedure? pred-eq))
  (if (null? lst)
    '()
    (let ((x-head (car lst))
          (l-tail (cdr lst)))
      (if (member x-head l-tail pred-eq)
        (delete-duplicates1 l-tail pred-eq)
        (cons x-head (delete-duplicates1 l-tail pred-eq))))))

(define (union-of-lists l1 l2 pred-eq)
  (assert (list? l1))
  (assert (list? l2))
  (assert (procedure? pred-eq))
  (delete-duplicates1 (append l1 l2) pred-eq))

(define (union-of-alists al1 al2 pred-eq)
  (assert (and (list? al1) (for-all pair? al1)))
  (assert (and (list? al2) (for-all pair? al2)))
  (assert (procedure? pred-eq))
  (delete-duplicates1
   (append al1 al2)
   (lambda (p1 p2) (pred-eq (car p1) (car p2)))))

(define (list-set-diff l1 l2 pred-eq)
  (fold (lambda (x-elem x-prev)
          (if (member x-elem l2 pred-eq)
            x-prev
            (cons x-elem x-prev)))
        '()
        l1))

(define (replace-list-element l i x-new-element)
  (assert (and (integer? i) (>= i 0)))
  (if (null? l )
    (raise-simple 'replace-list-element:empty-list)
    (if (eqv? i 0)
      (cons x-new-element (cdr l))
      (cons (car l) (replace-list-element (cdr l) (- i 1) x-new-element)))))

      
;; (define-syntax assert
;;   (syntax-rules ()
;;     ((assert condition)
;;      (do-assert condition (quote condition)))))

(define-syntax strong-assert
  (syntax-rules ()
    ((strong-assert condition)
     (assert condition))))

(define-method (make1 (clas <class>) . l-init-args)
  (let* ((x (make clas))
         (l-slots (class-slots clas))
         (l-slot-names (map slot-definition-name l-slots)))
    (assert (eqv? (length l-init-args) (length l-slot-names)))
    (for-each
     (lambda (s-slot-name x-value)
       (slot-set! x s-slot-name x-value))
     l-slot-names l-init-args)
     x))

(define-method (make-class1 s-name cl-parent l-fields)
  (assert (symbol? s-name))
  (assert (or (null? cl-parent) (is-a? cl-parent <class>)))
  (assert (and (list? l-fields) (for-all symbol? l-fields)))
  (let ((l-slots
         (map (lambda (s-slot-name) `(,s-slot-name #:init-value #f))
              l-fields)))
    (if (null? cl-parent)
      (make-class '() l-slots #:name s-name)
      (make-class (list cl-parent) l-slots #:name s-name))))


(define-syntax fluid-let
  (syntax-rules ()
    ((fluid-let () be ...)
     (begin be ...))
    ((fluid-let ((p0 e0) (p e) ...) be ...)
     (let ((saved p0))
       (set! p0 e0)
       (call-with-values (lambda ()
                           (fluid-let ((p e) ...) be ...))
                         (lambda results
                           (set! p0 saved)
                           (apply values results)))))))


(define-syntax unwind-protect-local
  (syntax-rules ()
    ((_ expr protect)
     (let ((result expr))
       protect
       result))))

       
(define-syntax iterate-list
  (syntax-rules ()
    ((_ (iter-var l) body1 ...)
     (letrec ((loop
                (lambda (l2)
                  (if (null? l2)
                    '()
                    (let ((iter-var (car l2)))
                      body1 ...
                      (loop (cdr l2)))))))
       (loop l)))))

(define-syntax iterate-list-with-break
  (syntax-rules ()
    ((_ (iter-var l condition) body1 ...)
     (letrec ((loop
                (lambda (l2)
                  (if (null? l2)
                    '()
                    (let ((iter-var (car l2)))
                      (if (not condition)
                        (begin
                         body1 ...
                         (loop (cdr l2)))))))))
       (loop l)))))
