vouivre/misc.scm

   1 ;;;; Copyright (C) 2023 Vouivre Digital Corporation
   2 ;;;;
   3 ;;;; This file is part of Vouivre.
   4 ;;;;
   5 ;;;; Vouivre is free software: you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU General Public
   7 ;;;; License as published by the Free Software Foundation, either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; Vouivre is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13 ;;;; General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public
  16 ;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
  17
  18 (define-module (vouivre misc)
  19   #:use-module (ice-9 arrays)
  20   #:use-module (ice-9 match)
  21   #:use-module (srfi srfi-1)
  22   #:export
  23   (alist<-plist
  24    array-map
  25    array-map-indexed
  26    but-last
  27    flip
  28    for-indices-in-range
  29    if-let
  30    ifn
  31    list-zeros
  32    map-indexed
  33    produce-array
  34    produce-typed-array))
  35
  36 (define (but-last lst)
  37   (if (null? lst)
  38       (error "List must contain at least one element.")
  39       (if (null? (cdr lst))
  40           '()
  41           (cons (car lst)
  42                 (but-last (cdr lst))))))
  43
  44 (define (alist<-plist plist)
  45   "Convert a property list to an association list."
  46   (cdr
  47    (fold-right
  48     (lambda (x prev)
  49       (match-let (((p . bindings) prev))
  50         (if (null? p)
  51             (cons (cons #f x) bindings)
  52             (begin
  53               (set-car! p x)
  54               (cons '() (cons p bindings))))))
  55     '(() . ())
  56     plist)))
  57
  58 (define (flip f)
  59   "Returns a procedure behaving as `f', but with arguments taken in reverse
  60 order."
  61   (lambda args
  62     (apply f (reverse args))))
  63
  64 (define-syntax if-let
  65   (syntax-rules ()
  66     [(_ (x test) consequent alternate)
  67      (let ([x test])
  68        (if x consequent alternate))]
  69     [(_ (x test) consequent)
  70      (let ([x test])
  71        (if x consequent))]))
  72
  73 (define-syntax ifn
  74   (syntax-rules ()
  75     [(_ test alternate consequent)
  76      (if test consequent alternate)]
  77     [(_ test alternate)
  78      (if (not test) alternate)]))
  79
  80 (define (list-zeros n)
  81   (list-tabulate n (lambda _ 0)))
  82
  83 (define (map-indexed f . lists)
  84   "Like `map' but the last argument of `f' is passed the corresponding index."
  85   (apply map f (append lists (list (list-tabulate (length (car lists))
  86                                                   identity)))))
  87
  88 (define (for-indices-in-range f starts ends)
  89   (define (for-indices-in-range% f indices starts ends)
  90     (if (null? starts)
  91         (apply f (reverse indices))
  92         (do ((i (car starts) (1+ i)))
  93             ((= i (car ends)))
  94           (for-indices-in-range%
  95            f
  96            (cons i indices)
  97            (cdr starts)
  98            (cdr ends)))))
  99   (for-indices-in-range% f '() starts ends))
 100
 101 ;;;; array utilities
 102
 103 (define (produce-typed-array f type . dims)
 104   (let ((a (apply make-typed-array type *unspecified* dims)))
 105     (array-index-map! a f)
 106     a))
 107
 108 (define (produce-array f . dims)
 109   (apply produce-typed-array f #t dims))
 110
 111 (define (array-map proc array . more)
 112   (let ((x (array-copy array)))
 113     (apply array-map! x proc array more)
 114     x))
 115
 116 (define (array-map-indexed proc array)
 117   (let ((x (array-copy array)))
 118     (array-index-map!
 119      x
 120      (lambda indices
 121        (apply proc
 122               (apply array-ref array indices)
 123               indices)))
 124     x))