A => and-let-star.scm +79 -0
@@ 0,0 1,79 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2017 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; I think this is compatible with and-let* from srfi-2.
+;; With and-let* you can chain things like let*, but it stops
+;; execution at any false value.
+;; example pulled out of my ass. might not work:
+;; (define (get-between-parens str)
+;; (and-let* ([start (string-index str #\()]
+;; [stop (string-index str #\)])
+;; (substring str (+ 1 start) stop)))
+;;
+;; Not providing a body will return the result of the last statement
+;;
+;; You can also use variables or expressions that are just checked
+;; for thruthiness and not bound to any identifier:
+;; (and-let* (should-we-log-stuff?
+;; ((> log-level 2)))
+;; (display "logged!"))
+;;
+;; Notice the extra parens aroud (> log-level [...]). If you don't include them
+;; and-let* will interpret two-clause expressions as (identifier value), so this
+;; will not do what you think:
+;; (and-let* ((b 5)
+;; (add1 b))
+;;
+;; It will bind the value of b to add1, and return that value (5). The proper way would
+;; be to either do that calculation in the body (which is clearer and less ambiguous), or
+;; write it ((add1 b))
+
+(import (rnrs))
+(define-syntax and-let*
+ (syntax-rules (bind let)
+ ;; the following 4 clauses are escape clauses.
+ ;; the first one is with a body
+ [(and-let* () body body* ...)
+ (begin body body* ...)]
+ ;; id and expr provided, but no body. Just evaluate expr
+ [(and-let* ((id expr)))
+ expr]
+ ;; only expr, evaluate
+ [(and-let* ((expr)))
+ expr]
+ ;; only a variable.
+ [(and-let* (var))
+ var]
+
+
+ [(and-let* (#:bind ((ids ...) expr) rest ...) . body)
+ (let-values (((ids ...) expr))
+ (and-let* (rest ...) . body))]
+
+ [(and-let* (#:bind (id expr) rest ...) . body)
+ (let ([id expr])
+ (and-let* (rest ...) . body))]
+
+ [(and-let* (#:let (bindings ...) rest ...) . body)
+ (let (bindings ...)
+ (and-let* (rest ...)
+ . body))]
+
+
+ [(and-let* (((ids ...) expr) rest ...) . body)
+ (let-values (((ids ...) expr))
+ (and ids ... (and-let* (rest ...) . body)))]
+
+ [(and-let* ((id expr) rest ...) . body)
+ (let ([id expr])
+ (and id (and-let* (rest ...) . body)))]
+ [(and-let* ((expr) rest ...) . body)
+ (and expr (and-let* ( rest ...) . body))]
+ [(and-let* (var rest ...) . body)
+ (and var (and-let* (rest ...) . body))]))
A => contract.scm +85 -0
@@ 0,0 1,85 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2017 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(library (contract)
+ (export
+ ->
+ listof vectorof
+ any/c or/c
+ integer-in fixnum-in flonum-in char-in
+ define/contract)
+ (import (rnrs (6))
+ (srfi srfi-1))
+ ;; auxiliary keyword ->
+ (define-syntax ->
+ (lambda (x)
+ (syntax-violation #f "misplaced aux keyword" x)))
+ ;;;;;;;;;;;;;;;;;;;;
+ ;; Useful predicate creators
+ ;;;;;;;;;;;;;;;;;;;;
+ (define (listof pred?)
+ (lambda (x)
+ (if (list? x)
+ (every pred? x)
+ #f)))
+
+ (define (vectorof pred?)
+ (lambda (x)
+ (let ([len (vector-length x)])
+ (let loop ([i 0])
+ (cond
+ [(= i len) #t]
+ [(pred? (vector-ref x i)) (loop (+ i 1))]
+ [else #f])))))
+
+ (define (any/c x)
+ #t)
+
+ (define (or/c . preds)
+ (lambda (x)
+ (let loop ([preds preds])
+ (cond
+ [(null? preds) #f]
+ [((car preds) x)]
+ [else (loop (cdr preds))]))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Number predicate creators ;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (in-range/c a b pred? st? bt? expected)
+ (lambda (x)
+ (if (and (pred? a) (pred? b))
+ (and (bt? x a) (st? x b))
+ #f)))
+
+ (define (between/c a b)
+ (in-range/c a b real? <= >= 'real))
+ (define (integer-in a b)
+ (in-range/c a b integer? <= >= 'integer))
+ (define (fixnum-in a b)
+ (in-range/c a b fixnum? fx<=? fx>=? 'fixnum))
+ (define (flonum-in a b)
+ (in-range/c a b flonum? fl<=? fl>=? 'flonum))
+ (define (char-in a b)
+ (in-range/c a b char? char<=? char>=? 'char))
+ (define-syntax define/contract
+ (syntax-rules (->)
+ [(define/contract (id var ...)
+ (-> pred? ... return-pred?) body ...)
+ (define (id var ...)
+ (define (%INTERNAL_PROC)
+ body ...)
+ (unless (pred? var) (error 'define/contract "contract error")) ...
+ (let ([%return-value (%INTERNAL_PROC)])
+ (if (return-pred? %return-value)
+ %return-value
+ (error 'define/contract "contract error"))))])))
+
+
A => goops-optional-arguments1.scm +75 -0
@@ 0,0 1,75 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Description
+;; A small utility to provide optional arguments to define-method, using the proper
+;; goops dispatch.
+;;
+;; A procedure definition of
+;; (define-method* (linus (hej <string>) #:optional (san <string> "hoj"))
+;; (string-append hej san))
+;;
+;; will expand into two different goops methods, (linus (hej <string>))
+;; and (linus (hej <string>) (san <string>)). The first one will just call
+;; linus with (linus hej "san") whereas the second one will contain the body of the
+;; procedure. Optional arguments can be given in two forms, either with type specifier
+;; and a default argument (num <integer> 1) or without any info, in which case
+;; it will be expanded to (name <top> #f). Rest arguments are only allowed for the last
+;; procedure when all optional args are provided. I could add optional arguments to all
+;; procedures but that seems like it could result in bad stuff like dispatching errors.
+;; It is certainly bad form
+;;
+;; it does _not_ and will never support keyword arguments since that will not play well
+;; with the dispatch system of goops (it can work using lambda*, but it will be a hack).
+;; You can of course hack it on by using rest arguments and lambda*
+
+
+(define-module (goops optional)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:export (define-method*))
+
+
+(define (is-optional? s)
+ (equal? #:optional (syntax->datum s)))
+
+
+(define (defaultify arg)
+ (syntax-case arg ()
+ [(arg type default)
+ #'(arg type default)]
+ [arg #'(arg <top> #f)]))
+
+
+(define-syntax define-method*
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ (proc args ... . rest) body ...) (any is-optional? #'(args ...))
+ (let-values ([(args optional) (break is-optional? #'(args ...))])
+ (with-syntax ([(args ...) args]
+ [optional (map defaultify (cdr optional))])
+ #'(%define-method* (proc args ... optional . rest) body ...))))
+ ((_ (proc args ... . rest) body ...)
+ #'(define-method (proc args ... . rest) body ...)))))
+
+
+(define-syntax %define-method*
+ (syntax-rules ()
+ [(_ (name args ... ()) body ...)
+ (define-method (name args ...) body ...)]
+ [(_ (name args ... () . rest) body ...)
+ (define-method (name args ... . rest) body ...)]
+ [(_ (name (args types) ... ((arg type default) (arg* type* default*) ...) . rest) body ...)
+ (begin
+ (define-method (name (args types) ... )
+ (name args ... default default* ...))
+ (%define-method* (name (args types) ... (arg type) ((arg* type* default*) ...) . rest)
+ body ...))]))
+
A => goops-optional-arguments2.scm +62 -0
@@ 0,0 1,62 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (srfi srfi-1)
+ (srfi srfi-11)
+ (oop goops))
+
+
+(define-syntax define-method*
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ (name args ... . rest?) body ...)
+ (let-values ([(regular optional)
+ (break (lambda (x) (keyword? (syntax->datum x))) #'(args ...))])
+ #`(define-method (name #,@regular . rest)
+ (apply (lambda* (#,@optional . rest?) body ...) rest)))])))
+
+
+
+
+;; This was in the file. Don't know if I ever used it.
+
+
+
+(define-method (str (any <top>))
+ (with-output-to-string
+ (lambda ()
+ (write any))))
+
+
+(define-method (str (any <top>) . rest)
+ (string-append (str any) " " (apply str rest)))
+
+
+(define-method (str (lis <pair>))
+ (string-append
+ "("
+ (let loop ([lis lis])
+ (cond
+ ((null? lis) "")
+ ((null? (cdr lis)) (str (car lis)))
+ ((not (pair? (cdr lis))) (string-append (str (car lis)) " . " (str (cdr lis))))
+ (else (string-append (str (car lis)) " " (loop (cdr lis))))))
+ ")"))
+
+
+(define-method (str (vec <vector>))
+ (define len (1- (vector-length vec)))
+ (string-append
+ "#("
+ (let loop ([i 0])
+ (if (= len i)
+ (str (vector-ref vec i))
+ (string-append (str (vector-ref vec i)) " " (loop (1+ i)))))
+ ")"))
+
A => memoize.scm +26 -0
@@ 0,0 1,26 @@
+;; A slow memoization macro. Uses hash tables.
+;; depends on guile's behaviour of letting one
+;; painlessly use lists as hash table keys.
+
+(define-module (memoize)
+ #:export (lambda/memo define/memo))
+
+(define-syntax define/memo
+ (syntax-rules ()
+ [(define/memo (name arg args ...)
+ body body* ...)
+ (define name
+ (lambda/memo (arg args ...)
+ body body* ...))]))
+
+(define-syntax lambda/memo
+ (syntax-rules ()
+ [(lambda/memo (arg args ...) body body* ...)
+ (let ([memory (make-hash-table)])
+ (lambda (arg args ...)
+ (let ([m (hash-ref memory (list arg args ...) #f)])
+ (if m
+ m
+ (let ([res (let () body body* ...)])
+ (hash-set! memory (list arg args ...) res)
+ res)))))]))
A => mutable-heap/mutable-heap.scm +168 -0
@@ 0,0 1,168 @@
+;; a pure r6rs mutable heap.
+
+;; Copyright 2017 Linus Björnstam
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(library (data mutable-heap)
+ (export
+ make-mutable-heap
+ mutable-heap?
+ heap-empty?
+ heap-add!
+ heap-min
+ heap-delete-min!
+ heap-delete-min-and-insert!
+ heap-pop!
+ heap-pop-and-insert!
+ heap-merge!
+ list->heap
+ heap->list!)
+
+ (import (rnrs base)
+ (rnrs control)
+ (rnrs records syntactic))
+
+ (define def-val 0)
+ (define-record-type mutable-heap
+ (fields
+ (immutable comparator)
+ (mutable storage)
+ (mutable growth-factor)
+ (mutable first-empty))
+ (protocol
+ (lambda (new)
+ (case-lambda
+ [()
+ (new < (make-vector 1000 def-val) 2 1)]
+ [(capacity)
+ (new < (make-vector capacity def-val) 2 1)]
+ [(capacity comparator)
+ (new comparator (make-vector capacity def-val) 2 1)]
+ [(capacity comparator growth-factor)
+ (new comparator (make-vector capacity def-val) growth-factor 1)])))
+ (opaque #t))
+
+ (define (prnt i)
+ (div i 2))
+
+ (define (left i)
+ (* 2 i))
+
+ (define (right i)
+ (+ 1 (* 2 i)))
+
+ (define (heapify! hp i)
+ (define cmp (mutable-heap-comparator hp))
+ (define heap-last (mutable-heap-first-empty hp))
+ (define l (left i))
+ (define r (right i))
+
+ (define smallest i)
+
+ (when (and (< l heap-last)
+ (cmp (storage-ref hp l) (storage-ref hp i)))
+ (set! smallest l))
+
+ (when (and (< r heap-last)
+ (cmp (storage-ref hp r) (storage-ref hp smallest)))
+ (set! smallest r))
+
+ (unless (= i smallest)
+ (storage-swap! hp i smallest)
+ (heapify! hp smallest)))
+
+ (define (heap-empty? hp)
+ (= 1 (mutable-heap-first-empty hp)))
+
+ ;; adds x to the end of x and percolates it upwards
+ (define (heap-add! hp x)
+ (define cmp (mutable-heap-comparator hp))
+ (let loop ([pos (storage-add! hp x)])
+ (let ([prnt-pos (prnt pos)])
+ (when (and (< 1 pos) (cmp x (storage-ref hp prnt-pos)))
+ (storage-swap! hp pos prnt-pos)
+ (loop prnt-pos)))))
+
+ (define (heap-min hp)
+ (when (heap-empty? hp)
+ (error 'heap-min "Heap is empty" hp))
+ (storage-ref hp 1))
+
+ (define (heap-delete-min! hp)
+ (when (heap-empty? hp)
+ (error 'heap-delete-min! "heap is empty"))
+ (storage-set! hp 1 def-val)
+ (let ([new-first-empty (- (mutable-heap-first-empty hp) 1)])
+ (storage-swap! hp 1 new-first-empty)
+ (mutable-heap-first-empty-set! hp new-first-empty))
+ (heapify! hp 1))
+
+ (define (heap-pop! hp)
+ (let ([res (heap-min hp)])
+ (heap-delete-min! hp)
+ res))
+
+ (define (heap-delete-min-and-insert! hp ins)
+ (storage-set! hp 1 ins)
+ (heapify! hp 1))
+
+ (define (heap-pop-and-insert! hp ins)
+ (let ([res (heap-min hp)])
+ (heap-delete-min-and-insert! hp ins)
+ res))
+
+ (define (heap-merge! h1 h2)
+ (unless (heap-empty? h2)
+ (heap-add! h1 (heap-pop! h2))
+ (heap-merge! h1 h2)))
+
+ (define (list->heap lst)
+ (define hp (make-mutable-heap (length lst)))
+ (let loop ([lst lst])
+ (unless (null? lst)
+ (heap-add! hp (car lst))
+ (loop (cdr lst))))
+ hp)
+
+ (define (heap->list! hp)
+ (let loop ([acc '()])
+ (if (heap-empty? hp)
+ (reverse acc)
+ (loop (cons (heap-pop! hp) acc)))))
+
+ ;; For internal use
+ (define (storage-add! hp val)
+ (cond
+ [(>= (mutable-heap-first-empty hp) (vector-length (mutable-heap-storage hp)))
+ (grow-storage! hp)
+ (storage-add! hp val)]
+ [else
+ (let ([new-element-pos (mutable-heap-first-empty hp)])
+ (storage-set! hp new-element-pos val)
+ (mutable-heap-first-empty-set! hp (+ 1 new-element-pos))
+ new-element-pos)]))
+
+ (define (grow-storage! hp)
+ (define newlen (* (vector-length (mutable-heap-storage hp)) (mutable-heap-growth-factor hp)))
+ (define new (make-vector newlen))
+ (vector-copy! (mutable-heap-storage hp) new 0 (vector-length (mutable-heap-storage hp)))
+ (mutable-heap-storage-set! hp new))
+
+ (define (storage-ref hp i)
+ (vector-ref (mutable-heap-storage hp) i))
+
+ (define (storage-set! hp pos val)
+ (vector-set! (mutable-heap-storage hp) pos val))
+
+ (define (storage-swap! hp i1 i2)
+ (let ([temp (storage-ref hp i1)])
+ (storage-set! hp i1 (storage-ref hp i2))
+ (storage-set! hp i2 temp)))
+
+ (define (vector-copy! from to start end)
+ (let loop ([i start])
+ (when (< i end)
+ (vector-set! to i (vector-ref from i))
+ (loop (+ i 1))))))
A => number->digits.scm +27 -0
@@ 0,0 1,27 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (srfi srfi-8))
+
+;; On my machine this is faster for numbers larger than 999
+(define (number->digits num)
+ (let ((str (number->string (abs num))))
+ (let loop ((i 0))
+ (if (= i (string-length str))
+ '()
+ (cons (- (char->integer (string-ref str i)) 48) (loop (1+ i)))))))
+
+
+;; faster for smaller numbers
+(define (number->digits2 num)
+ (let loop ((acc '()) (div num))
+ (if (< div 10)
+ (cons div acc)
+ (receive (div mod) (euclidean/ div 10)
+ (loop (cons mod acc) div)))))
A => pairing-heap/pairing-heap.scm +86 -0
@@ 0,0 1,86 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; A pairing heap implementation.
+;; All operations take a compare procedure as a first element.
+
+
+
+(library (pairing-heap)
+ (export
+ make-node
+ make-leaf
+ node?
+ node-empty?
+ node-merge
+ node-insert
+ node-min
+ node-delete-min
+ node-delete-min-and-inser
+ list->node node->list)
+ (import (rnrs))
+
+ (define-record-type leaf)
+ (define-record-type node
+ (fields
+ (immutable element)
+ (immutable subheaps))
+ (opaque #t))
+
+ (define (node-empty? h)
+ (leaf? h))
+
+ (define (merge-pairs cmp lst)
+ (cond
+ [(null? lst) (make-leaf)]
+ [(null? (cdr lst))
+ (car lst)]
+ [else
+ (node-merge cmp (node-merge cmp (car lst) (cadr lst))
+ (merge-pairs cmp (cddr lst)))]))
+
+ (define (node-merge cmp h1 h2)
+ (cond
+ [(leaf? h1) h2]
+ [(leaf? h2) h1]
+ [(cmp (node-element h1) (node-element h2))
+ (make-node (node-element h1)
+ (cons h2 (node-subheaps h1)))]
+ [else
+ (make-node (node-element h2)
+ (cons h1 (node-subheaps h2)))]))
+
+ (define (node-insert cmp h val)
+ (node-merge cmp h (make-node val '())))
+
+ (define (node-min h)
+ (node-element h))
+
+ (define (node-delete-min cmp h)
+ (merge-pairs cmp (node-subheaps h)))
+
+ ;; For most other heap implementations, this operation
+ ;; can provide a huge speedup compared to first removing
+ ;; and then inserting. For a pairing heap, is does not really matter
+ ;; but it is included for ease of porting
+ (define (node-delete-and-insert cmp h val)
+ (merge-pairs cmp (cons (make-node val '()) (node-subheaps h))))
+
+ (define (list->node cmp lst)
+ (let loop ([n (make-leaf)]
+ [lst lst])
+ (if (null? lst)
+ n
+ (loop (node-insert cmp n (car lst)) (cdr lst)))))
+
+ (define (node->list cmp n)
+ (let loop ([n n]
+ [acc '()])
+ (if (leaf? n)
+ (reverse acc)
+ (loop (node-delete-min cmp n) (cons (node-min n) acc))))))
A => readme.md +3 -0
@@ 0,0 1,3 @@
+# Misc utilities
+
+These are just some misc scripts I put online in case someone finds them useful. They are all written for guile scheme, but should be easily portable across implementations.