;;;;
;;;; 222.stk		-- Implementation of SRFI-222
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI by John Cowan and Arvydas Silanskas, it is copyrighted
;;;; as:
;;;;
;;;;;; Copyright © 2021 John Cowan, Arvydas Silanskas.
;;;;;;
;;;;;; Permission is hereby granted, free of charge, to any person obtaining
;;;;;; a copy of this software and associated documentation files (the
;;;;;; “Software”), to deal in the Software without restriction, including
;;;;;; without limitation the rights to use, copy, modify, merge, publish,
;;;;;; distribute, sublicense, and/or sell copies of the Software, and to
;;;;;; permit persons to whom the Software is furnished to do so, subject to
;;;;;; the following conditions:
;;;;;;
;;;;;; The above copyright notice and this permission notice (including the
;;;;;; next paragraph) shall be included in all copies or substantial
;;;;;; portions of the Software.
;;;;;;
;;;;;; THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND,
;;;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 28-Jul-2021 09:15 (jpellegrini)
;;;; Last file update: 29-Jun-2023 18:47 (eg)
;;;;

(define-module srfi/222
  (export    make-compound
             compound?
             compound-subobjects
             compound-length
             compound-ref
             compound-map
             compound-map->list
             compound-filter
             compound-predicate
             compound-access)


(define-record-type <compound-object>
    (raw-compound-object subobjs)
    compound?
  (subobjs raw-object-subobjects))

;; private
;; flatten list of objects and potentially other compounds
;; into simple list of objects without compounds
(define (assemble-subobjects in)
  (let loop ((in in)
             (out '()))
    (if (null? in)
	(reverse out)
	(loop (cdr in)
              (if (compound? (car in))
                  (append (reverse (compound-subobjects (car in))) out)
                  (cons (car in) out))))))

(define (make-compound . subobjs)
  (raw-compound-object (assemble-subobjects subobjs)))

(define (compound-subobjects obj)
  (if (compound? obj)
      (raw-object-subobjects obj)
      (list obj)))

(define (compound-length obj)
  (if (compound? obj)
      (length (raw-object-subobjects obj))
      1))

(define (compound-ref obj k)
  (if (compound? obj)
      (list-ref (compound-subobjects obj) k)
      obj))

(define (compound-map mapper obj)
  (if (compound? obj)
      (apply make-compound (compound-map->list mapper obj))
      (make-compound (mapper obj))))

(define (compound-map->list mapper obj)
  (map mapper (compound-subobjects obj)))

(define (filter pred list)
  (let loop ((list list) (result '()))
    (cond
     ((null? list)
      (reverse result))
     ((pred (car list))
      (loop (cdr list) (cons (car list) result)))
     (else
      (loop (cdr list) result)))))

(define (compound-filter pred obj)
  (define subobjs (filter pred (compound-subobjects obj)))
  (raw-compound-object subobjs))

(define (compound-predicate pred obj)
  (and
   (or
    ;; compound itself satisfies pred
    (pred obj)

    ;; compound has subobj that satisfies pred
    (let loop ((subobjs (compound-subobjects obj)))
      (cond
       ((null? subobjs) #f)
       ((pred (car subobjs)) #t)
       (else (loop (cdr subobjs))))))

   ;; if matched pred, convert result to #t
   #t))

(define (compound-access pred accessor default obj)
  (cond
   ((pred obj)
    (accessor obj))
   ((compound? obj)
    (let loop ((subobjs (compound-subobjects obj)))
      (cond
       ((null? subobjs) default)
       ((pred (car subobjs)) (accessor (car subobjs)))
       (else (loop (cdr subobjs))))))
   (else default)))

) ;;; END of module srfi/222

(provide "srfi/222")
