
;; 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 (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?
	    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))))
