;; © 2021 Idiomdrottning, BSD 1-Clause License
(module brev-separate

(define-ir-syntax define-syntax-rules define-ir-syntax*
  define-closure match-define match-define-closure
  call-table call-table* call-vector call-string
  for-each-line with-result over c_r like? is? define-curry c 🍛
  empty? eif econd define-some as-list)

(import scheme (chicken base) (chicken io) (chicken syntax)
	fast-generic matchable miscmacros srfi-1 srfi-69)
(import-for-syntax matchable miscmacros srfi-1)

(define-syntax define-ir-syntax
  (ir-macro-transformer
   (lambda (e i c)
     `(define-syntax ,(cadr e)
        (ir-macro-transformer
         (lambda (,(i 'exp) ,(i 'inject) ,(i 'compare))
           ,@(cddr e)))))))

(define-syntax define-syntax-rules
  (syntax-rules ()
    ((_ name arg ...)
     (define-syntax name
       (syntax-rules arg ...)))))

(define-syntax define-ir-syntax*
  (ir-macro-transformer
   (lambda (e i c)
     `(define-syntax ,(cadr e)
        (ir-macro-transformer
         (lambda (exp ,(i 'inject) ,(i 'compare))
           (match exp
             ,@(cddr e))))))))

(define-ir-syntax* define-closure
  ((define-closure bindings head body ...)
   (match (chicken.syntax#expand-curried-define head body '())
     ((define name body)
      `(define ,name
         (let
             ,(let desc ((lis bindings))
                (cons (list (car lis) (cadr lis))
                      (if (null? (cddr lis)) '() (desc (cddr lis)))))
           ,body))))))


(define-ir-syntax match-define
  `(define ,(caaadr exp)
     (match-lambda*
      ,@(map
         (lambda (el)
           (cons (cdar el) (cdr el)))
         (cdr exp)))))

(define-for-syntax caaaddr (o caaar cddr))
(define-ir-syntax match-define-closure
  `(define ,(caaaddr exp)
     (let
         ,(let desc ((lis (cadr exp)))
                  (cons (list (car lis) (cadr lis))
                        (if (null? (cddr lis)) '() (desc (cddr lis)))))
         (match-lambda*
          ,@(map
             (lambda (el)
               (cons (cdar el) (cdr el)))
             (cddr exp))))))

(define-closure
  (ht (make-hash-table))
  (call-table #!optional st #!key (default #f))
  (if st (set! ht (if (hash-table? st) st (alist->hash-table st))))
  (let ((proc
	 (match-lambda*
	  ((key)
	   (hash-table-ref/default ht key default))
	  (() ht)
	  ((#:update (? hash-table? new-ht)) (set! ht new-ht))
	  ((key val) (hash-table-set! ht key val)))))
    (getter-with-setter
     proc
     (lambda args (if (= 1 (length args)) (apply proc update: args) (apply proc args)))
     "call-table")))

(define-closure
  (ht (make-hash-table))
  (call-table* #!optional st #!key (initial '()) (proc cons) (unary #f))
  (if st (set! ht (if (hash-table? st) st (alist->hash-table st))))
  (let ((proc
	 (match-lambda*
	  ((key) (if unary
		     (hash-table-update! ht key proc (constantly initial))
		     (hash-table-ref/default ht key initial)))
	  (() ht)
	  ((#:update (? hash-table? new-ht)) (set! ht new-ht))
	  ((key val)
	   (hash-table-update! ht key (cut proc val <>) (constantly initial))))))
    (getter-with-setter
     proc
     (lambda args (if (= 1 (length args)) (apply proc update: args) (apply proc args)))
     "call-table*")))

(define-ir-syntax* for-each-line
  ((for-each-line filename . body)
   `(for-each
     (lambda (,(inject 'line))
       ,@body)
     (with-input-from-file
	 ,filename
       read-lines))))

(define-ir-syntax with-result
  `(let* ((ret #f)
	  (,( inject 'save)
	   (lambda (val)
	     (set! ret val)
	     val)))
     ,@(cdr exp)
     ret))

(define-syntax-rule
  (over bindings . body)
  (lambda lis
    (apply map (lambda bindings . body) lis)))

(define-ir-syntax c_r
  `(define (,(inject (cadr exp)) x)
     ,(fold list 'x
       (unfold-right
	null?
	(lambda (n) (case (car n) ((#\a) 'car) ((#\d) 'cdr)))
	cdr
	(cdr (butlast (string->list (symbol->string (strip-syntax (cadr exp))))))))))

;; Pre-curried versions of popular procedures
;; only cuts out a few letters (pun intended) but still

(define ((like? a) b) (equal? a b))
(define ((is? a) b) (eq? a b))

(define-syntax-rule
  (define-curry (name . args) . body)
  (define (name . friends)
    (if (= (length friends) (length 'args))
	(apply (lambda args . body)  friends)
	(lambda stragglers
	  (apply name (append friends stragglers))))))

(define (🍛 name . args)
  (lambda stragglers
    (apply name (append args stragglers))))
(define c 🍛)

(define-type boolean boolean?)
(define-type number number?)
(define-type integer integer?)
(define-type string string?)
(define-type vector vector?)
(define-type hash-table hash-table?)
(define-type list list?)

(define-generic (empty? (boolean x)) (not x))
(define-generic (empty? (number x)) (zero? x))
(define-generic (empty? (integer x)) (zero? x))
(define-generic (empty? (string x)) (zero? (string-length x)))
(define-generic (empty? (vector x)) (zero? (vector-length x)))
(define-generic (empty? (hash-table x)) (zero? (hash-table-size x)))
(define-generic (empty? (list x)) (null? x))

(define-ir-syntax* eif
  ((eif test yes no)
   `(let ((,(inject 'it) ,test))
      (if (empty? ,(inject 'it))
	  ,no ,yes))))

(define-syntax econd
  (syntax-rules (else =>)
    ((econd (else result1 result2 ...))
     (begin result1 result2 ...))
    ((econd (test => result))
     (eif test (result it)))
    ((econd (test => result) clause1 clause2 ...)
     (eif test
	  (result it)
	  (econd clause1 clause2 ...)))
    ((econd (test)) test)
    ((econd (test) clause1 clause2 ...)
     (eif test
	  it
	  (econd clause1 clause2 ...)))
    ((econd (test result1 result2 ...))
     (eif test (begin result1 result2 ...)))
    ((econd (test result1 result2 ...)
            clause1 clause2 ...)
     (eif test
          (begin result1 result2 ...)
          (econd clause1 clause2 ...)))))

(define-syntax-rule
  (define-some (name arg args ...) body ...)
  (define (name arg args ...)
    (if (empty? arg)
	'() (begin body ...))))

(define-generic (back-to (integer x)) (o string->number list->string (🍛 map integer->char)))
(define-generic (back-to (string x)) list->string)
(define-generic (back-to (vector x)) list->vector)
(define-generic (back-to (hash-table x)) alist->hash-table)
(define-generic (back-to (list x)) identity)
(define-generic (->list (integer x)) (map char->integer (string->list (number->string x))))
(define-generic (->list (string x)) (string->list x))
(define-generic (->list (vector x)) (vector->list x))
(define-generic (->list (hash-table x)) (hash-table->alist x))
(define-generic (->list (list x)) x)

(define ((as-list . procs) . xs)
  (let ((ret (apply (apply compose procs) (map ->list xs))))
    (if (list? ret)
	 ((back-to (car xs)) ret)
	 ret)))

(define-some (vector-mancala! vals vec index)
  (vector-set! vec index (car vals))
  (vector-mancala! (cdr vals) vec (add1 index)))

(define-some (string-mancala! vals str index)
  (string-set! str index (car vals))
  (string-mancala! (cdr vals) str (add1 index)))

(define (call-skele make-me me? opposite->me list->me me-mancala! me-ref me-set! me-err me-str me-length)
  (lambda (seed)
   (let ((vec
	  (cond
	   ((integer? seed) (make-me seed))
	   ((me? seed) seed)
	   ((list? seed) (list->me seed))
	   ((string? seed) (list->me (string->list seed)))
	   (else (error me-err)))))
     (let ((proc
	    (match-lambda*
	     (() vec)
	     ((#:update (? me? new-vec)) (set! vec new-vec) vec)
	     (((? integer? index)) (me-ref vec index))
	     (((? integer? index) val) (me-set! vec index val) vec)
	     ((#:slice start stop)
	      (unfold
	       (cute >= <>
		     (if (positive? stop) stop (+ stop (me-length vec))))
	       (cut me-ref vec <>)
	       add1
	       (if (negative? start) (+ (me-length vec) start) start)))
	     (((? integer? index) #:sow vals) (me-mancala! (->list vals) vec index) vec)
	     ((#:sow vals) (me-mancala! (->list vals) vec 0) vec)
	     (((? integer? index) #:sow val . vals) (me-mancala! (cons val vals) vec index) vec)
	     ((#:sow val . vals) (me-mancala! (cons val vals) vec 0) vec))))
       (getter-with-setter
	proc
	(lambda args (if (= 1 (length args)) (proc update: (car args)) (apply proc args)))
	me-str)))))

(define call-string
  (call-skele
   make-string
   string?
   (o list->string vector->list)
   list->string
   string-mancala!
   string-ref
   string-set!
   "No seed value provided for call-string"
   "call-string"
   string-length))

(define call-vector
  (call-skele
   make-vector
   vector?
   (o list->vector string->list)
   list->vector
   vector-mancala!
   vector-ref
   vector-set!
   "No seed value provided for call-vector"
   "call-vector"
   vector-length))

)