199 lines
8.0 KiB
Scheme
199 lines
8.0 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU Mes 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.
|
|
;;;
|
|
;;; GNU Mes 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; srfi-13.mes is the minimal srfi-13
|
|
|
|
;;; Code:
|
|
|
|
(mes-use-module (srfi srfi-14))
|
|
|
|
(define (string-join lst . delimiter+grammar)
|
|
(let ((delimiter (or (and (pair? delimiter+grammar) (car delimiter+grammar))
|
|
" "))
|
|
(grammar (or (and (pair? delimiter+grammar) (pair? (cdr delimiter+grammar)) (cadr delimiter+grammar))
|
|
'infix)))
|
|
(if (null? lst) ""
|
|
(case grammar
|
|
((infix) (if (null? (cdr lst)) (car lst)
|
|
(string-append (car lst) delimiter (string-join (cdr lst) delimiter))))
|
|
((prefix) (string-append delimiter (car lst) (apply string-join (cdr lst) delimiter+grammar)))
|
|
((suffix) (string-append (car lst) delimiter (apply string-join (cdr lst) delimiter+grammar)))))))
|
|
|
|
(define (string-copy s)
|
|
(list->string (string->list s)))
|
|
|
|
(define (string= a b . rest)
|
|
(let* ((start1 (and (pair? rest) (car rest)))
|
|
(end1 (and start1 (pair? (cdr rest)) (cadr rest)))
|
|
(start2 (and end1 (pair? (cddr rest)) (caddr rest)))
|
|
(end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
|
|
(string=? (if start1 (if end1 (substring a start1 end1)
|
|
(substring a start1))
|
|
a)
|
|
(if start2 (if end2 (substring b start2 end2)
|
|
(substring b start2))
|
|
b))))
|
|
|
|
(define (string-split s c)
|
|
(let loop ((lst (string->list s)) (result '()))
|
|
(let ((rest (memq c lst)))
|
|
(if (not rest) (append result (list (list->string lst)))
|
|
(loop (cdr rest)
|
|
(append result
|
|
(list (list->string (list-head lst (- (length lst) (length rest)))))))))))
|
|
|
|
(define (string-take s n)
|
|
(cond ((zero? n) s)
|
|
((> n 0) (list->string (list-head (string->list s) n)))
|
|
(else (error "string-take: not supported: n=" n))))
|
|
|
|
(define (string-drop s n)
|
|
(cond ((zero? n) s)
|
|
((> n 0) (list->string (list-tail (string->list s) n)))
|
|
(else s (error "string-drop: not supported: (n s)=" (cons n s)))))
|
|
|
|
(define (drop-right lst n)
|
|
(list-head lst (- (length lst) n)))
|
|
|
|
(define (string-drop-right s n)
|
|
(cond ((zero? n) s)
|
|
((> n 0) ((compose list->string (lambda (o) (drop-right o n)) string->list) s))
|
|
(else (error "string-drop-right: not supported: n=" n))))
|
|
|
|
(define (string-delete pred s)
|
|
(let ((p (if (procedure? pred) pred
|
|
(lambda (c) (not (eq? pred c))))))
|
|
(list->string (filter p (string->list s)))))
|
|
|
|
(define (string-index s pred . rest)
|
|
(let* ((start (and (pair? rest) (car rest)))
|
|
(end (and start (pair? (cdr rest)) (cadr rest)))
|
|
(pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
|
|
(if start (error "string-index: not supported: start=" start))
|
|
(if end (error "string-index: not supported: end=" end))
|
|
(let loop ((lst (string->list s)) (i 0))
|
|
(if (null? lst) #f
|
|
(if (pred (car lst)) i
|
|
(loop (cdr lst) (1+ i)))))))
|
|
|
|
(define (string-rindex s pred . rest)
|
|
(let* ((start (and (pair? rest) (car rest)))
|
|
(end (and start (pair? (cdr rest)) (cadr rest)))
|
|
(pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
|
|
(if start (error "string-rindex: not supported: start=" start))
|
|
(if end (error "string-rindex: not supported: end=" end))
|
|
(let loop ((lst (reverse (string->list s))) (i (1- (string-length s))))
|
|
(if (null? lst) #f
|
|
(if (pred (car lst)) i
|
|
(loop (cdr lst) (1- i)))))))
|
|
|
|
(define reverse-list->string (compose list->string reverse))
|
|
|
|
(define substring/copy substring)
|
|
(define substring/shared substring)
|
|
|
|
(define string-null? (compose null? string->list))
|
|
|
|
(define (string-fold cons' nil' s . rest)
|
|
(let* ((start (and (pair? rest) (car rest)))
|
|
(end (and start (pair? (cdr rest)) (cadr rest))))
|
|
(if start (error "string-fold: not supported: start=" start))
|
|
(if end (error "string-fold: not supported: end=" end))
|
|
(let loop ((lst (string->list s)) (prev nil'))
|
|
(if (null? lst) prev
|
|
(loop (cdr lst) (cons' (car lst) prev))))))
|
|
|
|
(define (string-fold-right cons' nil' s . rest)
|
|
(let* ((start (and (pair? rest) (car rest)))
|
|
(end (and start (pair? (cdr rest)) (cadr rest))))
|
|
(if start (error "string-fold-right: not supported: start=" start))
|
|
(if end (error "string-fold-right: not supported: end=" end))
|
|
(let loop ((lst (reverse (string->list s))) (prev nil'))
|
|
(if (null? lst) prev
|
|
(loop (cdr lst) (cons' (car lst) prev))))))
|
|
|
|
(define (string-contains string needle)
|
|
(let ((needle (string->list needle)))
|
|
(let loop ((string (string->list string)) (i 0))
|
|
(and (pair? string)
|
|
(let match ((start string) (needle needle) (n i))
|
|
(if (null? needle) i
|
|
(and (pair? start)
|
|
(if (eq? (car start) (car needle))
|
|
(or (match (cdr start) (cdr needle) (1+ n))
|
|
(loop (cdr string) (1+ i)))
|
|
(loop (cdr string) (1+ i))))))))))
|
|
|
|
(define (string-trim string . pred)
|
|
(list->string
|
|
(if (pair? pred) (error "string-trim: not supported: PRED=" pred)
|
|
(let loop ((lst (string->list string)))
|
|
(if (or (null? lst)
|
|
(not (char-whitespace? (car lst)))) lst
|
|
(loop (cdr lst)))))))
|
|
|
|
(define (string-trim-right string . pred)
|
|
(list->string
|
|
(reverse!
|
|
(if (pair? pred) (error "string-trim-right: not supported: PRED=" pred)
|
|
(let loop ((lst (reverse (string->list string))))
|
|
(if (or (null? lst)
|
|
(not (char-whitespace? (car lst)))) lst
|
|
(loop (cdr lst))))))))
|
|
|
|
(define (string-trim-both string . pred)
|
|
((compose string-trim string-trim-right) string))
|
|
|
|
(define (string-map f string)
|
|
(list->string (map f (string->list string))))
|
|
|
|
(define (string-replace string replace . rest)
|
|
(let* ((start1 (and (pair? rest) (car rest)))
|
|
(end1 (and start1 (pair? (cdr rest)) (cadr rest)))
|
|
(start2 (and end1 (pair? (cddr rest)) (caddr rest)))
|
|
(end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
|
|
(if start2 (error "string-replace: not supported: START2=" start2))
|
|
(if end2 (error "string-replace: not supported: END2=" end2))
|
|
(list->string
|
|
(append
|
|
(string->list (string-take string (or start1 0)))
|
|
(string->list replace)
|
|
(string->list (string-drop string (or end1 (string-length string))))))))
|
|
|
|
(define (string-downcase string)
|
|
(string-map char-downcase string))
|
|
|
|
(define (string-upcase string)
|
|
(string-map char-upcase string))
|
|
|
|
(define (string-tokenize string char-set)
|
|
(let loop ((lst (string->list string)) (result '()))
|
|
(if (null? lst) (reverse result)
|
|
(let match ((lst lst) (found '()))
|
|
(if (null? lst) (loop lst (if (null? found) (reverse result)
|
|
(cons (list->string (reverse found)) result)))
|
|
(let ((c (car lst)))
|
|
(if (not (char-set-contains? char-set c)) (loop (cdr lst)
|
|
(if (null? found) result
|
|
(cons (list->string (reverse found)) result)))
|
|
(match (cdr lst) (cons c found)))))))))
|