From d46183860c1f3f10095e95023adcb79b1896ab0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 22 Mar 2019 20:11:11 +0100 Subject: Move C and Scheme code into subdirs. --- module/util.scm | 168 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) create mode 100644 module/util.scm (limited to 'module/util.scm') diff --git a/module/util.scm b/module/util.scm new file mode 100644 index 00000000..6f1b955a --- /dev/null +++ b/module/util.scm @@ -0,0 +1,168 @@ +(define-module (util) + #:use-module (srfi srfi-1) + #:use-module ((sxml fold) #:select (fold-values)) + #:export (destructure-lambda let-multi fold-lists catch-let + for-each-in + define-quick-record define-quick-record! + mod! sort* sort*! + find-min) + #:replace (let*) + ) + +(define-public upstring->symbol (compose string->symbol string-upcase)) + +(define-public symbol-upcase (compose string->symbol string-upcase symbol->string)) + +(define-public symbol-downcase (compose string->symbol string-downcase symbol->string)) + +(define-syntax destructure-lambda + (syntax-rules () + ((_ expr-list body ...) + (lambda (expr) + (apply (lambda expr-list body ...) expr))))) + +(define-syntax catch-let + (syntax-rules () + ((_ thunk ((type handler) ...)) + (catch #t thunk + (lambda (err . args) + (case err + ((type) (apply handler err args)) ... + (else (format #t "Unhandled error type ~a, rethrowing ~%" err) + (apply throw err args)))))))) + +;;; For-each with arguments in reverse order. +(define-syntax-rule (for-each-in lst proc) + (for-each proc lst)) + + +;;; Helper macros to make define-quick-record better + +(define (class-name symb) (symbol-append '< symb '>)) +(define (constructor symb) (symbol-append 'make- symb)) +(define (pred symb) (symbol-append symb '?)) + +(define (getter name symb) (symbol-append 'get- name '- symb)) +(define* (setter name symb #:optional bang?) + (symbol-append 'set- name '- symb (if bang? '! (symbol)))) + +(define (%define-quick-record internal-define bang? name fields) + (let ((symb (gensym))) + `((,internal-define ,(class-name name) + (,(constructor name) ,@fields) + ,(pred name) + ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?))) + fields)) + ,@(map (lambda (f) `(define ,f (make-procedure-with-setter + ,(getter f symb) ,(setter f symb bang?)))) + fields)))) + +;;; Creates srfi-9 define{-immutable,}-record-type declations. +;;; Also creates srfi-17 accessor ((set! (access field) value)) + +;; (define (define-quick-record-templated define-proc name field)) + +(define-macro (define-quick-record name . fields) + (let ((public-fields (or (assoc-ref fields #:public) '())) + (private-fields (or (assoc-ref fields #:private) '()))) + `(begin + ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) + #f name + (append public-fields private-fields)) + ,@(map (lambda (field) `(export ,field)) + public-fields)))) + ;; (define-quick-record-templated 'define-immutable-record-type name fields)) + +;; (define-macro (define-quick-record! name . fields) +;; (define-quick-record-templated 'define-record-type name fields)) + +;; Replace let* with a version that can bind from lists. +;; Also supports SRFI-71 (extended let-syntax for multiple values) +;; @lisp +;; (let* ([a b (values 1 2)] ; @r{SRFI-71} +;; [(c d) '(3 4)] ; @r{Let-list (mine)} +;; [e 5]) ; @r{Regular} +;; (list e d c b a)) +;; ;; => (5 4 3 2 1) +;; @end lisp +(define-syntax let* + (syntax-rules () + + ;; Base case + [(_ () body ...) + (begin body ...)] + + ;; (let (((a b) '(1 2))) (list b a)) => (2 1) + [(_ (((k k* ...) list-value) rest ...) + body ...) + (apply (lambda (k k* ...) + (let* (rest ...) + body ...)) + list-value)] + + ;; "Regular" case + [(_ ((k value) rest ...) body ...) + (let ((k value)) + (let* (rest ...) + body ...))] + + ;; SRFI-71 let-values + [(_ ((k k* ... values) rest ...) body ...) + (call-with-values (lambda () values) + (lambda (k k* ...) + (let* (rest ...) + body ...)))] + + )) + +;; Like set!, but applies a transformer on the already present value. +(define-syntax-rule (mod! field transform-proc) + (set! field (transform-proc field))) + +(define-public (concat lists) + (apply append lists)) + +;; This function borrowed from web-ics (calendar util) +(define* (sort* items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort items (lambda (a b) + (comperator (get a) + (get b))))) + +;;; This function borrowed from web-ics (calendar util) +(define* (sort*! items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort! items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Finds the smallest element in @var{items}, compared with @var{<} after +;; applying @var{foo}. Returns 2 values. The smallest item in @var{items}, +;; and the other items in some order. +(define (find-min < ac items) + (if (null? items) + ;; Vad fan retunerar man här? + (values #f '()) + (fold-values + (lambda (c min other) + (if (< (ac c) (ac min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '()))) + +(define-public (filter-sorted proc list) + (take-while + proc (drop-while + (negate proc) list))) + +;; (define (!= a b) (not (= a b))) +(define-public != (negate =)) + +(define-public (take-to lst i) + "Like @var{take}, but might lists shorter than length." + (if (> i (length lst)) + lst (take lst i))) -- cgit v1.2.3