(defpackage :fwoar.string-utils
  (:use :cl)
  (:export #:get-part-modifier #:split))

(in-package :fwoar.string-utils)

(deftype array-length ()
  `(integer 0 ,array-dimension-limit))
(deftype array-index ()
  `(integer 0 ,(1- array-dimension-limit)))

(defun get-part-modifier (char string &optional count)
  (declare (optimize #+dev (debug 3) #-dev (speed 3))
	   (type character char)
	   (type string string))
  (flet ((count-splits (string)
	   (declare (optimize (speed 3))
		    (type simple-string string))
	   (do* ((x (the array-length 0) (1+ x))
		 (cur-char #1=(aref string x) #1#)
		 (result (the array-length 0) (if (char= cur-char char)
						  (1+ result)
						  result)))
		((= x (1- (length string))) (1+ result))
	     (declare (type array-length result)))))
    (typecase string
      ((and string (not simple-string))
       (setf string (copy-seq string))))
    (unless count
      (setf count (count-splits string))))
  (let ((parts (make-array count :initial-element nil :element-type '(or string null)))
	(start-idx 0)
	(target-spot 0))
    (prog1 parts
      (dotimes (end-idx (length string))
	(when (typecase string
		(simple-string (char= (aref string end-idx) char))
		(string (char= (aref string end-idx) char)))
	  (setf (aref parts target-spot)
		(make-array (- end-idx start-idx) :displaced-to string :displaced-index-offset start-idx
			    :element-type 'character))
	  (incf target-spot)
	  (setf start-idx (1+ end-idx))
	  (when (= target-spot (1- count))
	    (return))))
      (when (<= start-idx (length string))
	(setf (aref parts target-spot)
	      (make-array (- (length string) start-idx)
			  :displaced-to string :displaced-index-offset start-idx
			  :element-type 'character))))))

;; TODO: implement test
(defun %split-on-char (divider string &key count (test nil))
  (declare (optimize #+dev (debug 3) (speed 3) (space 2))
	   (type (or null array-length) count)
	   (type (or null function symbol) test)
	   (type character divider)
	   (type string string))
  (typecase string
    ((and string (not simple-string))
     (setf string (copy-seq string))))
  (check-type string simple-string)

  (flet ((count-splits (string)
	   (declare (optimize (speed 3))
		    (type simple-string string))
	   (do* ((x (the array-length 0) (1+ x))
		 (cur-char #1=(aref string x) #1#)
		 (result (the array-length 0) (if (char= cur-char divider)
						  (1+ result)
						  result)))
		((= x (1- (length string))) (1+ result))
	     (declare (type array-length result))))
	 (find-pos (start-pos)
	   (declare (optimize (speed 3))
		    (type array-index start-pos))
	   (etypecase test
	     (function (position divider string :start start-pos :test test))
	     (null (position divider string :start start-pos))
	     (symbol (position divider string :start start-pos :test (symbol-function test))))))

    (unless count
      (setf count (count-splits string)))

    (check-type count array-length)
    (let ((parts (make-array (1+ count) :fill-pointer 0))
	  (start-pos (the fixnum 0)))
      (declare (dynamic-extent start-pos))
      (prog1 parts
	(loop 
	   for end-pos = (find-pos start-pos)
	   while end-pos 
	   for num-parts from 0 to count
	   do
	     (vector-push (subseq string start-pos end-pos) parts)
	     (setf start-pos (1+ end-pos))
	   finally
	     (when (< start-pos (length string))
	       (vector-push (subseq string start-pos)
			    parts))
	     (when (eql divider (aref string (1- (length string))))
	       (vector-push (make-string 0)
			    parts)))))))

(defmacro twice (&body body)
  `(progn ,@body
	  ,@body))


(defun %split-on-string (divider string &key count (test nil))
  (declare (optimize #+dev (debug 3) (speed 3))
	   (type string divider string)
	   (type (or null function symbol) test)
	   (type (or null array-index) count))
  (flet ((%search (start-pos)
	   (declare (optimize (speed 3))
		    (type array-index start-pos)
		    (inline))
	   (typecase divider
	     (simple-string (typecase string
			      (simple-string (search divider string :start2 start-pos))
			      (string (search divider string :start2 start-pos))))
	     (string (search divider string :start2 start-pos))))
	 (%search-with-test (start-pos test)
	   (declare (optimize (speed 3))
		    (type array-index start-pos)
		    (type function test)
		    (inline))
	   (typecase divider
	     (simple-string (typecase string
			      (simple-string (search divider string :start2 start-pos :test test))
			      (string (search divider string :start2 start-pos :test test))))
	     (string (search divider string :start2 start-pos :test test)))))
    (declare (dynamic-extent (function %search)
			     (function %search-with-test)))
    (let ((num-parts (the array-length 0))
	  (pattern-length (the array-length (length divider)))
	  (search-test (typecase test
			 (function test)
			 (null)
			 (symbol (symbol-function test))))
	  (parts (make-array (if count count 100)
			     :adjustable t
			     :fill-pointer 0))
	  (start-pos 0))
      (loop 
	 for end-pos = (typecase search-test
			 (function (%search-with-test start-pos search-test))
			 (null (%search start-pos)))
	 do
	   (vector-push-extend (subseq string start-pos end-pos) parts) 
	   (incf (the array-length num-parts))
	 while end-pos
	 do (setf start-pos (the array-length (+ pattern-length end-pos)))
	 until (and count (>= (1+ num-parts) count))
	 finally
	   (when (and count end-pos)
	     (vector-push-extend (subseq string (+ pattern-length end-pos)) parts))
	   (return parts)))))

(defun split (divider string &key count (test nil) (type nil type-p))
  (declare (optimize #+dev (debug 3) (speed 3) (space 3)))
  (unless test
    (setf test
	  (typecase divider
	    (string 'equal)
	    (t 'eql))))
  (let ((result (etypecase divider
		  (character (%split-on-char divider string :count count :test test))
		  (string (if (= 1 (length divider))
			      (%split-on-char (aref divider 0) string :count count :test test)
			      (%split-on-string divider string :count count :test test))))))
    (if type-p
	(coerce result type)
	result)))