;;;; list-utils.operations.scm  -*- scheme -*-
;;;; 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
  #;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))

#;(: 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)))
              (let-values (((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)) ) ) ) ) )

;;

#| ;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)