8375de7966c7 — Linus Björnstam 5 years ago
Added stuff
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.