;;;; list-utils.operations.scm  -*- scheme -*-
;;;; Kon Lovett, Aug '25
;;;; Kon Lovett, Aug '23
;;;; Kon Lovett, Jul '07

(module (list-utils operations)

(;export
  list-unique/duplicates
  list-unique
  skip+
  split-at+
  section
  shift! unshift! shift!/set
  andmap ormap
  ensure-flat-list list-flatten
  fold-right*
  tree-fold
  #;maplist #;pair-map)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken fixnum) most-positive-fixnum))
(import (only (srfi 1) first reverse! append-reverse!))
(import (check-errors sys))

(define-type binary-test (* * -> *))

(: list-unique/duplicates (list #!optional binary-test -> list list))
(: list-unique (list #!optional binary-test -> list))

(: skip+ (list fixnum -> list fixnum))
(: split-at+ (list fixnum #!optional (or false list) -> list list))
(: section (list fixnum #!optional fixnum (or false list) -> list))

(: shift! (list #!optional * -> *))
(: unshift! (* list -> list))

(: andmap (procedure list #!rest list -> *))
(: ormap (procedure list #!rest list -> *))

(: *skip+ (list fixnum -> list fixnum))
(: *split-at+ (list fixnum (or false list) -> list list))

;fold-right* proc list . seeds
(: fold-right* ((* #!rest * -> . *) list #!rest * -> . *))

;per srfi-1.types fold
(: tree-fold ((* * -> *) * list -> list))

(: ensure-flat-list (* -> list))
(: list-flatten (list -> list))

#;(: maplist (procedure list #!rest list -> . *))
#;(: pair-map (procedure list #!rest list -> . *))

;;

(define-inline (check-positive-fixnum loc obj)
  (check-fixnum-in-range loc (check-fixnum loc obj) 1 most-positive-fixnum))

;;;

;; Unique sorted list

;=> (values ls dups)
;
(define (list-unique/duplicates ls #!optional (eqal? equal?))
  (check-procedure 'list-unique/duplicates eqal?)
  (let loop ((ils (check-list 'list-unique/duplicates ls)) (ols '()) (prev list-unique/duplicates) (dups '()))
    (if (null? ils)
        (values (reverse! ols) (reverse! dups))
        (let ((curr (first ils)) (rst (cdr ils)))
          (if (and (not (eq? list-unique/duplicates prev)) (eqal? prev curr))
              (loop rst ols prev (cons curr dups))
              (loop rst (cons curr ols) curr dups) ) ) ) ) )

;=> ls
;
(define (list-unique ls #!optional (eqal? equal?))
  (check-procedure 'list-unique eqal?)
  (let loop ((ils (check-list 'list-unique ls)) (ols '()) (prev list-unique))
    (if (null? ils) (reverse! ols)
        (let ((curr (car ils)) (rst (cdr ils)))
          (if (and (not (eq? list-unique prev)) (eqal? prev curr))
              (loop rst ols prev)
              (loop rst (cons curr ols) curr) ) ) ) ) )

;; Returns the original list starting at element n.

(define (skip+ ls n)
  (*skip+ (check-list 'skip+ ls) (check-fixnum 'skip+ n)) )

;; Returns new list with all elements [0 n-1] and original list from n.
;; The new list is padded upto n elements from pads, when supplied.
;; Returns partial split when fewer than n elements are available,
;; either from the primary or pad list, or no split when pads is #f. Default is
;; no padding & paritial section.

(define (split-at+ ls n #!optional pads)
  (*split-at+ (check-list 'split-at+ ls)
              (check-fixnum 'split-at+ n)
              (and pads (check-list 'split-at+ pads))) )

;; Returns sublists of length n from the list, the last sublist padded, if
;; necessary and possible, from pads. The sublists are constructed starting
;; at every step element.

;ls - list
;n - elements per section
;step - elements between section
;pads - remainder fill

(define (section ls n #!optional (step n) (pads '()))
       ;Do not attempt to section the padding list when
       ;the primary list is empty.
 (cond ((null? (check-list 'section ls))
          '() )
        ;Remaining elements between sections
        (else
          (let ((bias (- (check-positive-fixnum 'section step)
                         (check-positive-fixnum 'section n))) )
            (let loop ((ls ls) (parts '()))
              ;Get this section
              #;(assert (not (null? ls)))
              (receive (part nls) (*split-at+ ls n (and pads (check-list 'section pads)))
                (cond ((null? nls)
                        ;Possible empty section when no padding.
                        ;otherwise complete with this, the last, section
                        (reverse! (if (null? part) parts (cons part parts))) )
                      (else
                        ;Skip over "between" elements and continue sectioning the list.
                        (let ((ls (cond ((= 0 bias) ;step = n
                                          nls )
                                        ;step < n so skip from starting this
                                        ;section element
                                        ((> 0 bias)
                                          (receive (ls _) (*skip+ ls (+ n bias)) ls) )
                                        ;step > n so skip remaining elements
                                        ;in between
                                        (else
                                          (receive (ls _) (*skip+ nls bias) ls) ) ) ) )
                          (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )

;; shift! with a variable

(define-syntax shift!/set
  (syntax-rules (_tmp)
    ;
    ((shift!/set ?var)
      (shift!/set ?var #f) )
    ;
    ((shift!/set ?var ?empval)
      (if (not (pair? ?var)) ?empval
          (let ((_tmp (car ?var)))
            (set! ?var (cdr ?var))
            _tmp ) ) ) ) )

;; Returns #f if given list is empty and the list itself otherwise
;; It is intended for emulation of MIT-style empty list treatment
;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>

(define-syntax not-null?
  (syntax-rules (_obj)
    ((not-null? ?obj)
      (let ((_obj ?obj))
        (and (not (null? _obj))
             _obj) ) ) ) )

;;; Handy little things:

(define (shift! ls #!optional def)
  (if (null? (check-list 'shift! ls)) def
      (let ((x (car ls))
            (d (cdr ls)) )
        (check-pair 'shift! d)
        (set-car! ls (car d))
        (set-cdr! ls (cdr d))
        x ) ) )

(define (unshift! x ls)
  (check-pair 'unshift! ls)
  (set-car! ls x)
  (set-cdr! ls (cons (car ls) (cdr ls)))
  ls )

;;

(define (andmap func ls0 . rest)
        ;1 list
  (cond ((null? rest)
          (let mapf ((ls ls0))
            (or (null? ls)
                (and (func (car ls))
                     (mapf (cdr ls)))) ) )
        ;2 lists
        ((null? (cdr rest))
          (let mapf ((ls1 ls0) (ls2 (car rest)))
            (or (null? ls1)
                (and (func (car ls1) (car ls2))
                     (mapf (cdr ls1) (cdr ls2)))) ) )
        ;>2 lists
        (else
          (let mapf ((ls0 ls0) (rest rest))
            (or (null? ls0)
                (and (apply func (car ls0) (map car rest))
                     (mapf (cdr ls0) (map cdr rest)))) ) ) ) )

(define (ormap func ls0 . rest)
  (and (pair? ls0)
       (let ((rest (cons ls0 rest)))
         (or (apply func (map car rest))
             (apply ormap func (map cdr rest)) ) ) ) )

;;;

(define (*skip+ ls n)
  (if (or (null? ls) (<= n 0)) (values ls n)
      (*skip+ (cdr ls) (- n 1))) )

(define (*split-at+ ls n pads)
  ;Do not attempt to padout when the primary list is empty.
  (if (null? ls) (values '() '())
      (let loop ((ls ls) (n n) (part '()))
        (cond ((<= n 0)
                (values (reverse! part) ls) )
              ((null? ls)
                      ;Unless padding is desired throw away the section
                (cond ((not pads)
                        (values '() '()) )
                      ((null? pads)
                        (values (reverse! part) '()) )
                      (else
                        (receive (ls _) (*split-at+ pads n '())
                          (values (append-reverse! part ls) '()) ) ) ) )
              (else
                (loop (cdr ls) (- n 1) (cons (car ls) part)) ) ) ) ) )

;;

;Zipheir #scheme 08/22/25
(define (fold-right* proc list . seeds)
  (letrec
    ((fold/seed-list
      (lambda (list seeds)
        (if (null? list)
            (apply values seeds)
            (let-values ((seeds* (apply proc (car list) seeds)))
              (fold/seed-list (cdr list) seeds*))))) )

    (fold/seed-list list seeds) ) )

;flatwhatson #scheme 10/02/24
(define (tree-fold proc init ls)
  (let recur ((ls ls) (res init))
    (cond ((null? ls)
           res)
          ((pair? (car ls))
           (recur (cdr ls) (recur (car ls) res)))
          (else
           (recur (cdr ls) (proc (car ls) res))) ) ) )

;mnieper #scheme 10/02/24
(define (flatten/tail x tail)
  (if (pair? x) (foldr flatten/tail tail x)
      (cons x tail)) )

(define (list-flatten ls) (flatten/tail ls '()))

(define (ensure-flat-list x)
  (if (null? x) x
      ;will wrap an atom in a list,
      ;including '() so check above
      (flatten/tail x '())) )

;;

#| ;experimental
;Bird & Wadler 1988
(define (inits xs)
  (if (null? xs) '(())
      (cons '() (map (lambda (ys) (cons (car xs) ys)) (inits (cdr xs)))) ) )

(define (maplist fun . cls)
  (let loop ((cls cls))
    (if (any null? cls) '()
        (cons (receive (apply fun cls))
              (loop (##srfi1#cdrs cls) #;(map cdr cls))) ) ) )

(define (pair-map fun . cls)
  (apply pair-fold
         (lambda args
           (let-values (((cls ls) (split-at args (sub1 (length args)))))
             (cons (receive (apply fun cls)) ls) ) )
         '()
         cls))
|#

) ;module (list-utils operations)