Small snippets of Guile Scheme

log-expression: print variable name and value

(define foo 'bar)
(format #t "foo: ~a\n" foo)
;; or
(display 'foo)(display foo)(newline)

(define-syntax-rule (log-exprs exp ...) (begin (format #t "~a: ~S\n" (quote exp) exp) ...))

(define foo 'bar)
(log-exprs foo)
;; => foo: bar
(define bar 'baz)
(log-exprs foo bar (list "hello"))
;; foo: bar
;; bar: baz
;; (list hello): ("hello")

Use Guile-yaml to search for the first match in a yaml file

--- 
 doe: "a deer, a female deer"
 ray: "a drop of golden sun"
 pi: 3.14159
 xmas: true
 french-hens: 3
 calling-birds: 
   - huey
   - dewey
   - louie
   - fred
 xmas-fifth-day: 
   calling-birds: four
   french-hens: 3
   golden-rings: 5
   partridges: 
     count: 1
     location: "a pear tree"
   turtle-doves: two

(import (yaml) (ice-9 match))
(define demo (read-yaml-file "demo1.yml"))
(let match-demo ((demo demo))
  (match demo
    ((("partridges" . b) c ...) b)
    (else (if (pair? demo)
              (or (match-demo (cdr demo)) (match-demo (car demo)))
              #f))))
;; => (("count" . "1") ("location" . "a pear tree"))

Count occurences of each key in an alist

(define xydata '((1 . 1)(1 . 2)(1 . 3)(2 . 1)(2 . 2)))

(define (assoc-increment! key alist)
  "Increment the value of the key in the alist, set it to 1 if it does not exist."
  (define res (assoc key alist))
  (assoc-set! alist key (or (and=> (and=> res cdr) 1+) 1)))

(fold assoc-increment! '() (map car xydata))
;; => ((2 . 2) (1 . 3))

Common Substrings and Somewhat Cheap String Similarity

• Get all common substrings
  
  • Usage
    

    Different from the requirements in in Rosetta Code, this returns not the longest common substring, but all non-consecutive substrings.

    (longest-common-substrings "thisisatest" "testing123testing")
    ;; => ("test" "i")
    (longest-common-substrings "thisisatestrun" "thisisatestunseen")
    ;; => ("thisisatest" "un")
    

  • Implementation
    

    Warning: This is NOT fast. It takes a few seconds when run over two text documents with around 2000 characters each.

    (import (srfi srfi-1))
    (define (longest-common-substrings s1 s2)
      (define c1 (string->list s1))
      (define c2 (string->list s2))
      (define (common-prefix a b)
        (let loop ((prefix '()) (a a) (b b))
          (cond ((or (null? a) (null? b)) (reverse! prefix))
                ((not (equal? (car a) (car b))) (reverse! prefix))
                (else (loop (cons (car a) prefix) (cdr a) (cdr b))))))
      (define (longer a b)
        (if (> (length a) (length b))
            a b))
      (define (common-substrings a b)
        (define substrings '())
        (let loop ((a2 a) (b b) (longest '()))
          (let ((prefix (common-prefix a2 b)))
            (let ((anew (drop a2 (length prefix))))
              (when (not (null? prefix))
                ;; (format #t "a2 ~a\nanew ~a\nb ~a\n\n" (apply string a2) (apply string anew) (apply string b))
                (let ((str (apply string prefix)))
                  (when (not (member str substrings))
                    (set! substrings (cons str substrings)))))
              (cond ((null? b) #t) ;; done
                    ((null? anew)
                     (loop a (cdr b) '()))
                    ((null? prefix)
                     (loop (cdr anew) b longest))
                    (else
                     (loop (cdr anew) b (longer prefix longest)))))))
        substrings)
      (let ((substrings (common-substrings c1 c2)))
        (define (contained-in-any-other s)
          (any identity (map (λ (s2) (and (not (equal? s s2)) (string-contains s2 s))) substrings)))
        (reverse! (remove contained-in-any-other substrings))))
    

• Somewhat Cheap String Similarity
  
  • Usage
    

    (cheap-similarity "thisisatest" "thisisatest")
    ;; => 3.0454545454545454
    (cheap-similarity "thisisatest" "thisisatestrun")
    ;; => 2.68
    (cheap-similarity "thisisatest" "testing123testing")
    ;; => 1.2142857142857142
    (cheap-similarity "thisisatest" "criecriecriecrie")
    ;; => 0.4444444444444444
    

  • Implementation
    

    Warning: This is NOT well defined and is mostly untested, so it might have ugly unforseed edge-cases and might give bad results for large classes of problems. It seems to do what I want (get the similarity of filenames for ordering streams by similarity for the guile media site), and it was interesting no write, but that’t about it. Use with caution!

    (import (srfi srfi-1))
    (define (all-common-substrings s1 s2)
      (define c1 (string->list s1))
      (define c2 (string->list s2))
      (define (common-prefix a b)
        (let loop ((prefix '()) (a a) (b b))
          (cond ((or (null? a) (null? b)) (reverse! prefix))
                ((not (equal? (car a) (car b))) (reverse! prefix))
                (else (loop (cons (car a) prefix) (cdr a) (cdr b))))))
      (define (longer a b)
        (if (> (length a) (length b))
            a b))
      (define (common-substrings a b)
        (define substrings '())
        (let loop ((a2 a) (b b) (longest '()))
          (let ((prefix (common-prefix a2 b)))
            (let ((anew (drop a2 (length prefix))))
              (when (not (null? prefix))
                (let ((str (apply string prefix)))
                  (set! substrings (cons str substrings))))
              (cond ((null? b) #t) ;; done
                    ((null? anew)
                     (loop a (cdr b) '()))
                    ((null? prefix)
                     (loop (cdr anew) b longest))
                    (else
                     (loop (cdr anew) b (longer prefix longest)))))))
        substrings)
      (let ((substrings (common-substrings c1 c2)))
        (define (contained-in-any-other s)
          (any identity (map (λ (s2) (and (not (equal? s s2)) (string-contains s2 s))) substrings)))
        substrings))
    
    (define (cheap-similarity s1 s2)
      (define common-length (apply + (map string-length (all-common-substrings s1 s2))))
      (define total-length (+ (string-length s1) (string-length s2)))
      (/ common-length total-length 1.))