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

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

#lang racket

(provide myfind
	 mymemq
	 general-member
	 general-assoc
	 myevery
	 myany
	 mylast
	 my-drop
	 my-take
	 my-drop-right
	 my-take-right
	 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
	 if1)


;; (require srfi/1)
(require (except-in rnrs assert))


;; (define (myfind pred l)
;;   (if (null? l)
;;       #f
;;       (let ((x-head (car l)))
;; 	(if (pred x-head)
;; 	    x-head
;; 	    (myfind pred (cdr l))))))


(define myfind find)


;; (define (mymemq x l)
;;   (if (null? l)
;;       #f
;;       (if (eq? x (car l))
;; 	  l
;; 	  (mymemq x (cdr l)))))


(define mymemq memq)


(define (general-member x l pred)
  (if (null? l)
      #f
      (let ((x-head (car l)))
	(if (pred x x-head)
	    l
	    (general-member x (cdr l) pred)))))


(define (general-assoc x-key al pred)
  (if (null? al)
      #f
      (let ((p-cur (car al)))
	(if (pred x-key (car p-cur))
	    p-cur
	    (general-assoc x-key (cdr al) pred)))))


(define (myevery pred . lists)
  (if (mymemq '() lists)
      #t
      (let ((l-heads (map car lists)))
	(if (apply pred l-heads)
	    (apply myevery pred (map cdr lists))
	    #f))))


(define (myany pred . lists)
  (if (mymemq '() lists)
      #f
      (let ((l-heads (map car lists)))
	(if (apply pred l-heads)
	    #t
	    (apply myany pred (map cdr lists))))))


(define (mylast l)
  (if (null? l)
      (raise 'mylast:empty-list)
      (let ((l-tail (cdr l)))
      (if (null? l-tail)
	  (car l)
	  (mylast l-tail)))))


(define (my-take l i-count)
  (cond
   ((= i-count 0) '())
   ((< i-count 0) (raise 'my-take:invalid-count))
   (else
    (cons (car l) (my-take (cdr l) (- i-count 1))))))


(define (my-drop l i-count)
  (cond
   ((= i-count 0) l)
   ((< i-count 0) (raise 'my-drop:invalid-count))
   (else (my-drop (cdr l) (- i-count 1)))))


(define (my-take-right lis k)
  (let lp ((lag lis)  (lead (my-drop lis k)))
    (if (pair? lead)
	(lp (cdr lag) (cdr lead))
	lag)))


(define (my-drop-right lis k)
  (let recur ((lag lis) (lead (my-drop lis k)))
    (if (pair? lead)
	(cons (car lag) (recur (cdr lag) (cdr lead)))
	'())))


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


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

;; Not sure if the following is correct.
(define map-in-order map)
(define map* map)

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

(define-syntax if1
  (syntax-rules ()
    ((if1 condition then-expr)
     (if condition then-expr (void)))))
