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

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


(library (th-scheme-utilities stdutils)

  (export 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?
	  assert
	  strong-assert)


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


  (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-syntax assert
  ;;   (syntax-rules ()
  ;;     ((assert condition)
  ;;      (do-assert condition (quote condition)))))
  
  (define-syntax strong-assert
    (syntax-rules ()
      ((strong-assert condition)
       (assert condition)))))
