;; © 2021 Idiomdrottning, BSD 1-Clause License
;; contributions from Chris Brannon

(module brev-separate

(define-ir-syntax define-syntax-rules define-ir-syntax*
  define-closure define-parameters match-define match-define-closure
  call-table call-table* call-vector call-string call-list
  call-table? call-table*? call-vector? call-string? call-list?
  ct ctq ct* ctq*
  call-record call-record? niy descend
  call-key* call-key*? for-each-line for-each-stdin aif-with-result with-result
  fn over make-tree-accessor make-sloppy-tree-accessor scar scdr
  like? is? normalize-absolute-pathname newline1 skip1
  define-curry c 🍛 empty? eif econd define-some slice as-list as-string
  ?-> with memoize keep ->list list-> record? string->dwim string->read)

(import scheme (chicken base) (chicken io) (chicken pathname)
	(chicken port) (chicken process-context) (chicken syntax)
	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 (exp ,(i 'inject) ,(i 'compare))
	   (let ((,(i 'body) (cdr exp)))
            ,@(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)
     (let ((cand (caadr e)))
       `(define-syntax ,(if (pair? cand) (car cand) cand)
          (ir-macro-transformer
           (lambda (exp ,(i 'inject) ,(i 'compare))
             (match exp
               ,@(if (pair? cand) (cdr e) (list (cdr e)))))))))))

(define-ir-syntax*
  (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 ,(caaar body)
     (match-lambda*
      ,@(map
         (lambda (el)
           (cons (cdar el) (cdr el)))
         body))))

(define-for-syntax caaaddr (o caaar cddr))

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

(define
  (call-table #!key (seed (make-hash-table)) (default #f))
  (let* ((ht (if (hash-table? seed) seed (alist->hash-table seed)))
	(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
  (call-table* #!key (seed (make-hash-table)) (initial '()) (proc cons) (unary #f))
  (let* ((ht (if (hash-table? seed) seed (alist->hash-table seed)))
	 (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 (call-key* #!key (initial '()) (proc cons) (unary #f))
  (let ((proc
	 (match-lambda*
	  (() (if unary (set! initial (proc initial)) initial))
	  ((#:get) initial)
	  ((#:update lis) (set! initial lis))
	  ((val) (set! initial (proc val initial))))))
    (getter-with-setter proc proc "call-key*")))

(define (call-table->alist ct)
  (hash-table->alist (ct)))

(define-ir-syntax*
((for-each-line filename . body)
   `(call-with-input-file ,filename
      (lambda (in-port)
	(port-for-each
	 (lambda (,(inject 'line)) ,@body)
	 (cut read-line in-port))))))

(define-ir-syntax*
  (for-each-stdin . body)
  `(port-for-each
    (lambda (,(inject 'line)) ,@body)
    read-line))

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

(define-ir-syntax aif-with-result
  `(let* ((,(inject 'it) #f)
	  (,( inject 'save)
	   (lambda (val)
	     (set! ,(inject 'it) val)
	     val)))
     (if ,@body)))

(define-ir-syntax fn
  (let ((friends
	 (let desc ((friends '()) (body body))
	   (cond
	    ((null? body)
	     friends)
	    ((and (pair? body)
		  (any (cut compare (car body) <>) '(fn over)))
	     friends)
	    ((pair? body) (append (desc friends (car body)) (desc friends (cdr body))))
	    ((memq (strip-syntax body) '(x y z rest args))
	     (cons (strip-syntax body) friends))
	    (else '())))))
    `(lambda ,(cond
	       ((memq 'z friends)
		(cons* (inject 'x) (inject 'y) (inject 'z) (inject 'rest)))
	       ((memq 'y friends)
		(cons* (inject 'x) (inject 'y) (inject 'rest)))
	       ((memq 'x friends)
		(cons (inject 'x) (inject 'rest)))
	       (else (inject 'args)))
       ,@body)))

(define-ir-syntax make-tree-accessor
  `(define (,(car body) 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 (car body))))))))))

(define (scar x)
  (if (null? x) '() (car x)))

(define (scdr x)
  (if (null? x) '() (cdr x)))

(define-ir-syntax make-sloppy-tree-accessor
  `(define (,(car body) x)
     ,(fold list 'x
       (unfold-right
	null?
	(lambda (n) (case (car n) ((#\a) 'scar) ((#\d) 'scdr)))
	cdr
	(cddr (butlast (string->list (symbol->string (strip-syntax (car body))))))))))

;; 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-ir-syntax*
  (with var . body)
  `(let ((,(inject 'it) ,var))
     ,@body))

(match-define
 ((empty? (? null? x)) #t)
 ((empty? (? boolean? x)) (not x))
 ((empty? (? number? x)) (zero? x))
 ((empty? (? integer? x)) (zero? x))
 ((empty? (? string? x)) (zero? (string-length x)))
 ((empty? (? vector? x)) (zero? (vector-length x)))
 ((empty? (? hash-table? x)) (zero? (hash-table-size x)))
 ((empty? x) #f))

(define-ir-syntax*
  (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-ir-syntax*
  (descend bindings . body)
  (letrec ((names
	    (map (lambda (el)
		   (if (atom? el) el (car el)))
		 bindings))
	   (vals
	    (map (lambda (el)
		   (if (atom? el) el (cadr el)))
		 bindings))
	   (descer?
	    (lambda (el)
	      (and (pair? el)
		   (eq? (inject 'desc) (car el)))))
	   (deep
	    (lambda (body)
	      (cond
	       ((null? body) '())
	       ((atom? body) body)
	       ((eq? (inject 'descend) (car body)) body)
	       ((and (any descer? body))
		`(if (empty? ,(cadr (find descer? body)))
		     ,(let ((filtered (map deep (remove descer? body))))
			(cond
			 ((eq? (inject 'cons) (car body))
			  (cons 'list (cdr filtered)))
			 ((= 2 (length filtered)) (cadr filtered))
			 ((= 1 (length filtered)) '(void))
			 (else filtered)))
		     ,body))
	       (else (map deep body)))))
	   (top-level
	    (lambda (body)
	      (cond
	       ((null? body) '())
	       ((atom? body) (list body))
	       ((eq? (inject 'descend) (car body)) (list body))
	       ((and (any descer? body))
		`((if (empty? ,(cadr (find descer? body)))
		      ,(let ((filtered (map deep (remove descer? body))))
			 (if (= 1 (length filtered))
			     (car filtered)
			     (cons 'begin filtered)))
		      ,(if (= 1 (length body))
			   (car body)
			   (cons 'begin body)))))
	       (else (map deep body))))))
    `((if
       (empty? ,(car vals))
       (letrec ((,(inject 'desc)
		 (lambda ,names
		   ,@body)))
	 ,(inject 'desc))
       (letrec ((,(inject 'desc)
		 (lambda ,names
		   ,@(top-level body))))
	 ,(inject 'desc)))
      ,@vals)))

(define (record? x)
  (and
   (not (##sys#immediate? x))
   (##sys#structure? x (##sys#slot x 0))))

(match-define
 ((list-> (? list? x)) identity)
 ((list-> (? integer? s))
  (fn
   (if (and (list? x) (every integer? x))
    ((o string->number list->string
	(c append-map (o string->list number->string))) x)
    x)))
 ((list-> (? string? s))
  (fn (descend (x)
	       (if (list? x)
		   (if (every char? x)
		       (list->string x)
		       (map desc x))
		   x))))
 ((list-> (? symbol? s)) (fn (string->symbol (list->string x))))
 ((list-> (? vector? x)) list->vector)
 ((list-> (? hash-table? x)) alist->hash-table)
 ((list-> (? record? r)) (fn (apply ##sys#make-structure (##sys#slot r 0) x))))

(match-define
 ((->list (? list? x)) x)
 ((->list (? symbol? x)) (string->list (symbol->string x)))
 ((->list (? integer? x))
   (map (o string->number string) (string->list (number->string x))))
 ((->list (? string? x)) (string->list x))
 ((->list (? vector? x)) (vector->list x))
 ((->list (? hash-table? x)) (hash-table->alist x))
 ((->list (? record? x)) (map (cut ##sys#slot x <>) (iota (sub1 (##sys#size x)) 1))))

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

(match-define
 ((string-> (? integer? x)) string->number)
 ((string-> (? list? x)) string->list)
 ((string-> (? vector? x)) (o list->vector string->list))
 ((string-> (? string? x)) identity)
 ((string-> (? symbol? x)) string->symbol))

(match-define
 ((b->string (? integer? x)) (number->string x))
 ((b->string (? string? x)) x)
 ((b->string (? vector? x)) (list->string (vector->list x)))
 ((b->string (? list? x)) (list->string x))
 ((b->string (? symbol? x)) (symbol->string x)))

(define ((as-string . procs) . xs)
  (let ((ret (apply (apply compose procs) (map b->string xs))))
    (if (string? ret)
	 ((string-> (car xs)) ret)
	 ret)))

(define (mancala-skele me-set! me-length)
  (rec (desc vals vec index)
   (cond
    ((null? vals) vec)
    ((< index (me-length vec))
     (me-set! vec index (car vals))
     (desc (cdr vals) vec (add1 index)))
    (else
     (warning "Attempting to sow past boundary, truncating")
     vec))))

(define (call-skele make-me me? list->me 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))))
	  (flip (lambda (start) (if (negative? start) (+ (me-length vec) start) start)))
	  (me-mancala! (mancala-skele me-set! me-length)))
     (let ((proc
	    (match-lambda*
	     (() vec)
	     ((#:update (? me? new-vec)) (set! vec new-vec) vec)
	     (((? integer? index)) (me-ref vec (flip index)))
	     (((? integer? index) val) (me-set! vec (flip index) val) vec)
	     ((#:slice start stop)
	      (unfold
	       (cut >= <>
		     (if (positive? stop) stop (+ stop (me-length vec))))
	       (cut me-ref vec <>)
	       add1
	       (flip start)))
	     (((? integer? index) #:sow vals) (me-mancala! (->list vals) vec (flip index)))
	     ((#:sow vals) (me-mancala! (->list vals) vec 0))
	     (((? integer? index) #:sow val . vals) (me-mancala! (cons val vals) vec (flip index)))
	     ((#:sow val . vals) (me-mancala! (cons val vals) vec 0)))))
       (getter-with-setter
	proc
	(lambda args (cond
		 ((= 1 (length args)) (proc update: (car args)))
		 ((eq? #:slice (car args))
		  (let* ((la (->list (last args)))
			 (leo (- (flip (third args)) (flip (second args))))
			 (len (length la)))
		    (unless (= leo len)
		      (warning "Attempting to set! to mismatched slice, truncating"))
		    (proc (second args)
			  sow: (take la
				     (min leo len)))))
		 (else (apply proc args))))
	me-str)))))

(define call-list
  (call-skele
   make-list
   list?
   identity
   list-ref
   (lambda (lis index val)
     (set-car! (drop lis index) val))
   "No seed value provided for call-list"
   "call-list"
   length))

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

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

(define (call-record record)
  (if (record? record)
   ((call-skele
     void
     (conjoin record? (fn (eq? (##sys#slot record 0)  (##sys#slot x 0))))
     (list-> record)
     (fn (##sys#slot x (add1 y)))
     (fn (##sys#block-set! x (add1 y) z))
     #f
     "call-record"
     (fn (sub1 (##sys#size x))))
    record)
   (error "No seed record provided for call-record")))

;; This one owes a debt to Mario's callable-data-structures!
(define ((pred-skele sym) obj)
  (and (procedure? obj)
       (eq? (procedure-information obj) sym)))

(define call-table? (pred-skele 'call-table))
(define call-table*? (pred-skele 'call-table*))
(define call-string? (pred-skele 'call-string))
(define call-vector? (pred-skele 'call-vector))
(define call-list? (pred-skele 'call-list))
(define call-record? (pred-skele 'call-record))
(define call-key*? (pred-skele 'call-key*))

(match-define
 ((->sliceable (? list? x)) (call-list x))
 ((->sliceable (? vector? x)) (call-vector x))
 ((->sliceable (? string? x)) (call-string x))
 ((->sliceable (? record? x)) (call-record x))
 ((->sliceable x) (call-list (->list x))))

(define slice
  (getter-with-setter
   (lambda (anything start stop)
     ((->sliceable anything) slice: start stop))
   (lambda (anything start stop new)
     (set! ((->sliceable anything) slice: start stop) new))
   "slice"))

(define (normalize-absolute-pathname file)
  (normalize-pathname
   (if (absolute-pathname? file)
       file
       (make-absolute-pathname
	(current-directory) file))))

(define (niy . test)
  (if
   (null? test)
   (error "Not implemented yet!")
   (descend (test)
	    (if (car test)
		(error  "Unimplemented value case!")
		(desc (cdr test))))))

(define-syntax-rules
  ctq ()
  ((ctq key val)
   (let ((ht (call-table)))
     (ht `key `val)
     ht))
  ((ctq key val more ...)
   (let ((ht (ctq more ...)))
     (ht `key `val)
     ht)))

(define-syntax-rules
  ct ()
  ((ct key val)
   (let ((ht (call-table)))
     (ht key val)
     ht))
  ((ct key val more ...)
   (let ((ht (ct more ...)))
     (ht key val)
     ht)))

(define-syntax-rules
  ctq* ()
  ((ctq* key val)
   (let ((ht (call-table*)))
     (ht `key `val)
     ht))
  ((ctq* key val more ...)
   (let ((ht (ctq* more ...)))
     (ht `key `val)
     ht)))

(define-syntax-rules
  ct* ()
  ((ct* key val)
   (let ((ht (call-table*)))
     (ht key val)
     ht))
  ((ct* key val more ...)
   (let ((ht (ct* more ...)))
     (ht key val)
     ht)))

(define (skip1 . procs)
  (let ((ran #f))
   (lambda args
    (cond ((equal? '(reset) args) (set! ran #f))
	  (ran (apply (apply compose procs) args))
	  (else (set! ran #t))))))

(define newline1 (skip1 newline))

(define-syntax-rules
  define-parameters ()

  ((define-parameters name value)
   (define name (make-parameter value)))

  ((define-parameters n1 v1 n2 v2 ...)
   (begin
     (define-parameters n1 v1)
     (define-parameters n2 v2 ...))))

(define ((?-> predicate transformer . args) value)
  (cond ((predicate value)
	 (transformer value))
	((null? args)
	 value)
	(else (last args))))

(define (memoize proc)
  (let ((ht (call-table)))
    (fn (eif (ht args) it (with-result (ht args (save (apply proc args))))))))

(define-syntax-rule (memoize! name) (define name (memoize name)))

(define keep
  (case-lambda
   ((proc) (fn (apply proc args) (last args)))
   ((proc . args) (apply proc args) (last args))))

(define-ir-syntax over
  `(lambda seqs
     (let ((lists (map ->list seqs)))
       ((list-> (car seqs))
	(apply map
	       (lambda (,(inject 'i) . more)
		 (apply (fn ,@body) more))
	       (iota (length (car lists)))
	       lists)))))

(define (string->read str) (with-input-from-string str read))

(define (string->dwim str)
  (with (string->read str)
	(if (equal? str (with-output-to-string (fn (write it))))
	    it
	    str)))

)