(define my-dict '((a b) (1 hello) ("c" (a b c)))
(assoc 'a my-dict)                               ; evaluates to '(a b)

(define my-alist '((a b) (1 hello) ("c" (a b c)))
(define my-hash (alist->hash-table my-alist))

#!r6rs

(import (rnrs base)
        (rnrs hashtables (6)))

(define my-hash (make-hashtable equal-hash equal?))
(hashtable-set! my-hash 'a 'b)
(hashtable-set! my-hash 1 'hello)
(hashtable-set! my-hash "c" '(a b c))
Works with: CHICKEN version 5.3.0
Library: r7rs
Library: srfi-1
Library: srfi-151

(cond-expand
  (r7rs)
  (chicken (import r7rs)))

(define-library (avl-trees)

  ;;
  ;; This library implements ‘persistent’ (that is, ‘immutable’) AVL
  ;; trees for R7RS Scheme.
  ;;
  ;; References:
  ;;
  ;;   * Niklaus Wirth, 1976. Algorithms + Data Structures =
  ;;     Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
  ;;
  ;;   * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
  ;;     by Fyodor Tkachov, 2014.
  ;;
  ;; THIS IS A TRIMMED-DOWN VERSION OF MY SOLUTION TO THE AVL TREES
  ;; TASK: https://rosettacode.org/wiki/AVL_tree#Scheme
  ;;

  (export avl)
  (export avl?)
  (export avl-empty?)
  (export avl-insert)
  (export avl-search-values)
  (export avl-check-usage)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (scheme process-context))
  (import (scheme write))

  (begin

    (define-syntax avl-check-usage
      (syntax-rules ()
        ((_ pred msg)
         (or pred (usage-error msg)))))

    (define-record-type <avl>
      (%avl key data bal left right)
      avl?
      (key %key)
      (data %data)
      (bal %bal)
      (left %left)
      (right %right))

    (define (avl)
      (%avl #f #f #f #f #f))

    (define (avl-empty? tree)
      (avl-check-usage
       (avl? tree)
       "avl-empty? expects an AVL tree as argument")
      (not (%bal tree)))

    (define (avl-search-values pred<? tree key)
      ;; Return two values: the data matching the key, or #f is the
      ;; key is not found; and a second value that is either #f or #t,
      ;; depending on whether the key is found.
      (define (search p)
        (if (not p)
            (values #f #f)
            (let ((k (%key p)))
              (cond ((pred<? key k) (search (%left p)))
                    ((pred<? k key) (search (%right p)))
                    (else (values (%data p) #t))))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-search-values expects a procedure as first argument")
      (if (avl-empty? tree)
          (values #f #f)
          (search tree)))

    (define (avl-insert pred<? tree key data)

      (define (search p fix-balance?)
        (cond
         ((not p)
          ;; The key was not found. Make a new node and set
          ;; fix-balance?
          (values (%avl key data 0 #f #f) #t))

         ((pred<? key (%key p))
          ;; Continue searching.
          (let-values (((p1 fix-balance?)
                        (search (%left p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              p1 (%right p))))
                (values p^ #f)))
             (else
              ;; A new node has been inserted on the left side.
              (case (%bal p)
                ((1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 p1 (%right p))))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) -1
                                 p1 (%right p))))
                   (values p^ fix-balance?)))
                ((-1)
                 ;; Rebalance.
                 (case (%bal p1)
                   ((-1)
                    ;; A single LL rotation.
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%right p1) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      (%left p1) p^)))
                      (values p1^ #f)))
                   ((0 1)
                    ;; A double LR rotation.
                    (let* ((p2 (%right p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (min bal2 0))
                                     (%right p2) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (max bal2 0))
                                      (%left p1) (%left p2)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p1^ p^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))

         ((pred<? (%key p) key)
          ;; Continue searching.
          (let-values (((p1 fix-balance?)
                        (search (%right p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              (%left p) p1)))
                (values p^ #f)))
             (else
              ;; A new node has been inserted on the right side.
              (case (%bal p)
                ((-1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 (%left p) p1)))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) 1
                                 (%left p) p1)))
                   (values p^ fix-balance?)))
                ((1)
                 ;; Rebalance.
                 (case (%bal p1)
                   ((1)
                    ;; A single RR rotation.
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%left p) (%left p1)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      p^ (%right p1))))
                      (values p1^ #f)))
                   ((-1 0)
                    ;; A double RL rotation.
                    (let* ((p2 (%left p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (max bal2 0))
                                     (%left p) (%left p2)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (min bal2 0))
                                      (%right p2) (%right p1)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p^ p1^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))

         (else
          ;; The key was found; p is an existing node.
          (values (%avl key data (%bal p) (%left p) (%right p))
                  #f))))

      (avl-check-usage
       (procedure? pred<?)
       "avl-insert expects a procedure as first argument")
      (if (avl-empty? tree)
          (%avl key data 0 #f #f)
          (let-values (((p fix-balance?) (search tree #f)))
            p)))

    (define (internal-error)
      (display "internal error\n" (current-error-port))
      (emergency-exit 123))

    (define (usage-error msg)
      (display "Procedure usage error:\n" (current-error-port))
      (display "  " (current-error-port))
      (display msg (current-error-port))
      (newline (current-error-port))
      (exit 1))

    )) ;; end library (avl-trees)

(define-library (associative-arrays)

  ;;
  ;; Persistent associative arrays for R7RS Scheme.
  ;;
  ;; The story:
  ;;
  ;; An implementation of associative arrays, where keys are compared
  ;; with an ‘equal to’ predicate, typically has three parts:
  ;;
  ;;    * a hash function, which converts a key to a hash value; and
  ;;      the hash value either has a ‘less than’ predicate or can be
  ;;      put in a radix tree;
  ;;
  ;;    * a table keyed by the hash values;
  ;;
  ;;    * a way to resolve hash value collisions.
  ;;
  ;; At one extreme is the association list, which can be viewed as
  ;; having a hash function that *always* collides. At a nearly
  ;; opposite extreme are ideal hash trees, which never have
  ;; collisions, but which, towards that end, require hash values to
  ;; ‘grow’ on the fly.
  ;;
  ;; Perhaps the simplest form of associative array having all three
  ;; parts is ‘separate chaining’: the hash function generates an
  ;; integer modulo some table size; the table itself is an array of
  ;; that size; and collisions are resolved by falling back to an
  ;; association list.
  ;;
  ;; Below I use my solution to the AVL Tree task
  ;; (https://rosettacode.org/wiki/AVL_tree#Scheme) to implement
  ;; *persistent* (that is, ‘immutable’) associative arrays. The hash
  ;; function is whatever you want, as long as it produces (what
  ;; Scheme regards as) a real number. Hash value collisions are
  ;; resolved by falling back to association lists.
  ;;

  (export assoc-array)
  (export assoc-array?)
  (export assoc-array-set)
  (export assoc-array-ref)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (scheme write))
  (import (avl-trees))

  (cond-expand
    (chicken (import (only (srfi 1) alist-delete)))
    ;; Insert whatever you need here for your Scheme.
    (else))

  (begin

    (define-record-type <assoc-array>
      (%assoc-array hashfunc pred=? default table)
      assoc-array?
      (hashfunc %hashfunc)
      (pred=? %pred=?)
      (default %default)
      (table %table))

    (define assoc-array
      ;; Create an associative array.
      (case-lambda
        ((hashfunc)
         (let ((pred=? equal?)
               (default #f))
           (assoc-array hashfunc pred=? default)))
        ((hashfunc pred=?)
         (let ((default #f))
           (assoc-array hashfunc pred=? default)))
        ((hashfunc pred=? default)
         (%assoc-array hashfunc pred=? default (avl)))))

    (define (assoc-array-set array key data)
      ;; Produce a new associative array that is the same as the input
      ;; array except for the given key-data association. The input
      ;; array is left unchanged (which is why the procedure is called
      ;; ‘assoc-array-set’ rather than ‘assoc-array-set!’).
      (let ((hashfunc (%hashfunc array))
            (pred=? (%pred=? array))
            (default (%default array))
            (table (%table array)))
        (let ((hash-value (hashfunc key)))
          ;; The following could be made more efficient by combining
          ;; the ‘search’ and ‘insert’ operations for the AVL tree.
          (let*-values
              (((alst found?) (avl-search-values < table hash-value)))
            (cond
             (found?
              ;; Add a new entry to the association list. Removal of
              ;; any old associations with the key is not strictly
              ;; necessary, but without it the associative array will
              ;; grow every time you replace an
              ;; association. (Alternatively, you could occasionally
              ;; clean the associative array of shadowed key
              ;; associations.)
              (let* ((alst (alist-delete key alst pred=?))
                     (alst `((,key . ,data) . ,alst))
                     (table (avl-insert < table hash-value alst)))
                (%assoc-array hashfunc pred=? default table)))
             (else
              ;; Start a new association list.
              (let* ((alst `((,key . ,data)))
                     (table (avl-insert < table hash-value alst)))
                (%assoc-array hashfunc pred=? default table))))))))

    (define (assoc-array-ref array key)
      ;; Return the data associated with the key. If the key is not in
      ;; the table, return the associative array’s default data.
      (let* ((hashfunc (%hashfunc array))
             (hash-value (hashfunc key)))
        (let*-values
            (((alst found?)
              (avl-search-values < (%table array) hash-value)))
          (if found?
              (let ((pair (assoc key alst (%pred=? array))))
                (if pair
                    (cdr pair)
                    (%default array)))
              (%default array)))))

    )) ;; end library (associative-arrays)

(cond-expand
  (DEMONSTRATION
   (begin
     (import (scheme base))
     (import (scheme write))
     (import (srfi 151))
     (import (associative-arrays))

     ;; I like SpookyHash, but for this demonstration I shall use the
     ;; simpler ‘ElfHash’ and define it only for strings. See
     ;; https://en.wikipedia.org/w/index.php?title=PJW_hash_function&oldid=997863283
     (define (hashfunc s)
       (let ((n (string-length s))
             (h 0))
         (do ((i 0 (+ i 1)))
             ((= i n))
           (let* ((ch
                   ;; If the character is outside the 8-bit range,
                   ;; probably I should break it into four bytes, each
                   ;; incorporated separately into the hash. For this
                   ;; demonstration, I shall simply discard the higher
                   ;; bits.
                   (bitwise-and (char->integer (string-ref s i))
                                #xFF))
                  (h^ (+ (arithmetic-shift h 4) ch))
                  (high^ (bitwise-and h^ #xF0000000)))
             (unless (zero? high^)
               (set! h^
                 (bitwise-xor h^ (arithmetic-shift high^ -24))))
             (set! h (bitwise-and h^ (bitwise-not high^)))))
         h))

     (let* ((a1 (assoc-array hashfunc))
            (a2 (assoc-array-set a1 "A" #\A))
            (a3 (assoc-array-set a2 "B" #x42)) ; ASCII ‘B’.
            (a4 (assoc-array-set a3 "C" "C")))
       (write (assoc-array-ref a1 "A")) (newline)
       (write (assoc-array-ref a1 "B")) (newline)
       (write (assoc-array-ref a1 "C")) (newline)
       (write (assoc-array-ref a2 "A")) (newline)
       (write (assoc-array-ref a2 "B")) (newline)
       (write (assoc-array-ref a2 "C")) (newline)
       (write (assoc-array-ref a3 "A")) (newline)
       (write (assoc-array-ref a3 "B")) (newline)
       (write (assoc-array-ref a3 "C")) (newline)
       (write (assoc-array-ref a4 "A")) (newline)
       (write (assoc-array-ref a4 "B")) (newline)
       (write (assoc-array-ref a4 "C")) (newline))

     ))
  (else))

create an associative array or dictionary. The implementation is persistent and immutable, using AVL Tree task code. It also includes generators or iterators that are executable procedures. This is not a native feature of Scheme but a library add-on. The performance is logarithmic on average due to the nature of the AVL Tree.


The code replicates two historic random number generators - the rand() function from BSD libc and the rand() function from the Microsoft C Runtime (MSCVRT.DLL). It uses the linear congruential generator formula to generate a sequence of random numbers, given a seed. The generated sequence matches the sequence produced by the original generators when starting from the same seed. The BSD formula generates random numbers in the range 0 to 2147483647, while the Microsoft formula generates random numbers in the range 0 to 32767.


(define (insert-after a b lst)
  (if (null? lst)
      lst       ; This should be an error, but we will just return the list untouched
      (let ((c (car lst))
            (cs (cdr lst)))
        (if (equal? a c)
            (cons a (cons b cs))
            (cons c (insert-after a b cs))))))

(define (insert-after! a b lst)
  (let ((pos (member a lst)))
    (if pos
        (set-cdr! pos (cons b (cdr pos))))))

"Implement a method to insert an element into a singly-linked list after a given element. Specifically, the code inserts element C into a list of elements A->B, following element A."


(define (halve num)
  (quotient num 2))

(define (double num)
  (* num 2))

(define (*mul-eth plier plicand acc)
  (cond ((zero? plier) acc)
        ((even? plier) (*mul-eth (halve plier) (double plicand) acc))
        (else (*mul-eth (halve plier) (double plicand) (+ acc plicand)))))

(define (mul-eth plier plicand)
  (*mul-eth plier plicand 0))

(display (mul-eth 17 34))
(newline)

578

The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. These functions are used to implement Ethiopian multiplication, a method that multiplies two integers using only addition, doubling, and halving. The multiplication process involves creating a table where the left column repeatedly halves a number until it reaches 1, and the right column doubles a number in sync. Rows where the left column has an even number are discarded, and the remaining values in the right column are summed to get the multiplication result.


#!r6rs

(import (rnrs)
        (rnrs eval)
        (only (srfi :1 lists) append-map delete-duplicates iota))

(define (map* fn . lis)
  (if (null? lis)
      (list (fn))
      (append-map (lambda (x)
                    (apply map*
                           (lambda xs (apply fn x xs))
                           (cdr lis)))
                  (car lis))))

(define (insert x li n)
  (if (= n 0)
      (cons x li)
      (cons (car li) (insert x (cdr li) (- n 1)))))

(define (permutations li)
  (if (null? li)
      (list ())
      (map* insert (list (car li)) (permutations (cdr li)) (iota (length li)))))

(define (evaluates-to-24 expr)
  (guard (e ((assertion-violation? e) #f))
    (= 24 (eval expr (environment '(rnrs base))))))

(define (tree n o0 o1 o2 xs)
  (list-ref
   (list
    `(,o0 (,o1 (,o2 ,(car xs) ,(cadr xs)) ,(caddr xs)) ,(cadddr xs))
    `(,o0 (,o1 (,o2 ,(car xs) ,(cadr xs)) ,(caddr xs)) ,(cadddr xs))
    `(,o0 (,o1 ,(car xs) (,o2 ,(cadr xs) ,(caddr xs))) ,(cadddr xs))
    `(,o0 (,o1 ,(car xs) ,(cadr xs)) (,o2 ,(caddr xs) ,(cadddr xs)))
    `(,o0 ,(car xs) (,o1 (,o2 ,(cadr xs) ,(caddr xs)) ,(cadddr xs)))
    `(,o0 ,(car xs) (,o1 ,(cadr xs) (,o2 ,(caddr xs) ,(cadddr xs)))))
   n))

(define (solve a b c d)
  (define ops '(+ - * /))
  (define perms (delete-duplicates (permutations (list a b c d))))
  (delete-duplicates
   (filter evaluates-to-24
           (map* tree (iota 6) ops ops ops perms))))

> (solve 1 3 5 7)
((* (+ 1 5) (- 7 3))
 (* (+ 5 1) (- 7 3))
 (* (+ 5 7) (- 3 1))
 (* (+ 7 5) (- 3 1))
 (* (- 3 1) (+ 5 7))
 (* (- 3 1) (+ 7 5))
 (* (- 7 3) (+ 1 5))
 (* (- 7 3) (+ 5 1)))
> (solve 3 3 8 8)
((/ 8 (- 3 (/ 8 3))))
> (solve 3 4 9 10)
()

The code takes four digits as input, either from the user or generated randomly, and computes arithmetic expressions according to the rules of the 24 game. It also provides examples of solutions it has generated. The code outputs an S-expression that evaluates to 24.


(define (factorial n)
  (if (<= n 0)
      1
      (* n (factorial (- n 1)))))

(define (factorial n)
  (let loop ((i 1)
             (accum 1))
    (if (> i n)
        accum
        (loop (+ i 1) (* accum i)))))
(define (factorial n)
  (do ((i 1 (+ i 1))
       (accum 1 (* accum i)))
      ((> i n) accum)))
;Using a generator and a function that apply generated values to a function taking two arguments

;A generator knows commands 'next? and 'next
(define (range a b)
(let ((k a))
(lambda (msg)
(cond
	((eq? msg 'next?) (<= k b))
	((eq? msg 'next)
	(cond
		((<= k b) (set! k (+ k 1)) (- k 1))
		(else 'nothing-left)))))))

;Similar to List.fold_left in OCaml, but uses a generator
(define (fold fun a gen)
(let aux ((a a))
	(if (gen 'next?) (aux (fun a (gen 'next))) a)))

;Now the factorial function
(define (factorial n) (fold * 1 (range 1 n)))

(factorial 8)
;40320

"Function to calculate the factorial of a number using either iterative or recursive methods, with optional error handling for negative input values."


Works with: any R6RS Scheme
;generate a random non-repeating list of 4 digits, 1-9 inclusive
(define (get-num)
  (define (gen lst)
    (if (= (length lst) 4) lst
        (let ((digit (+ (random 9) 1)))
          (if (member digit lst) ;make sure the new digit isn't in the
                                 ;list
              (gen lst)
              (gen (cons digit lst))))))
  (string->list (apply string-append (map number->string (gen '())))))

;is g a valid guess (that is, non-repeating, four digits 1-9
;inclusive?)
(define (valid-guess? g)
  (let ((g-num (string->number (apply string g))))
    ;does the same digit appear twice in lst?
    (define (repeats? lst)
      (cond ((null? lst) #f)
            ((member (car lst) (cdr lst)) #t)
            (else (repeats? (cdr lst)))))
    (and g-num
         (> g-num 1233)
         (< g-num 9877)
         (not (repeats? g)))))

;return '(cows bulls) for the given guess
(define (score answer guess)
  ;total cows + bulls
  (define (cows&bulls a g)
    (cond ((null? a) 0)
          ((member (car a) g) (+ 1 (cows&bulls (cdr a) g)))
          (else (cows&bulls (cdr a) g))))
  ;bulls only
  (define (bulls a g)
    (cond ((null? a) 0)
          ((equal? (car a) (car g)) (+ 1 (bulls (cdr a) (cdr g))))
          (else (bulls (cdr a) (cdr g)))))
  (list (- (cows&bulls answer guess) (bulls answer guess)) (bulls answer guess)))

;play the game
(define (bull-cow answer)
  ;get the user's guess as a list
  (define (get-guess)
    (let ((e (read)))
      (if (number? e)
          (string->list (number->string e))
          (string->list (symbol->string e)))))
  (display "Enter a guess: ")
  (let ((guess (get-guess)))
    (if (valid-guess? guess)
        (let ((bulls (cadr (score answer guess)))
              (cows (car (score answer guess))))
          (if (= bulls 4)
              (display "You win!\n")
              (begin
                (display bulls)
                (display " bulls, ")
                (display cows)
                (display " cows.\n")
                (bull-cow answer))))
        (begin
          (display "Invalid guess.\n")
          (bull-cow answer)))))

(bull-cow (get-num))

Enter a guess: 1234
0 bulls, 1 cows.
Enter a guess: 2345
1 bulls, 0 cows.
Enter a guess: 2346
1 bulls, 1 cows.
Enter a guess: 2367
0 bulls, 1 cows.
Enter a guess: 2647
1 bulls, 1 cows.
Enter a guess: 2648
2 bulls, 1 cows.
Enter a guess: 2468
1 bulls, 2 cows.
Enter a guess: 1468
1 bulls, 2 cows.
Enter a guess: 2684
0 bulls, 3 cows.
Enter a guess: 6248
3 bulls, 0 cows.
Enter a guess: 6948
You win!

generate a unique four-digit number, accept and validate user guesses, calculate and print scores based on matching digits and their positions, and end the program when the user guess matches the generated number.


; linear congruential generator given in C99 section 7.20.2.1
(define ((c-rand seed)) (set! seed (remainder (+ (* 1103515245 seed) 12345) 2147483648)) (quotient seed 65536))

; uniform real numbers in open interval (0, 1)
(define (unif-rand seed) (let ((r (c-rand seed))) (lambda () (/ (+ (r) 1) 32769.0))))

; Box-Muller method to generate normal distribution
(define (normal-rand unif m s)
(let ((? #t) (! 0.0) (twopi (* 2.0 (acos -1.0))))
(lambda ()
   (set! ? (not ?))
   (if ? !
         (let ((a (sqrt (* -2.0 (log (unif))))) (b (* twopi (unif))))
              (set! ! (+ m (* s a (sin b))))
              (+ m (* s a (cos b))))))))

(define rnorm (normal-rand (unif-rand 0) 1.0 0.5))

; auxiliary function to get a list of 'n random numbers from generator 'r
(define (rand-list r n) = (if (zero? n) '() (cons (r) (rand-list r (- n 1)))))

(define v (rand-list rnorm 1000))

v
#|
(-0.27965824722565835
 -0.8870860825789542
 0.6499618744638194
 0.31336141955110863
 ...
 0.5648743998193049
 0.8282656735558756
 0.6399951934564637
 0.7699535302478072)
|#

; check mean and standard deviation
(define (mean-sdev v)
(let loop ((v v) (a 0) (b 0) (n 0))
(if (null? v)
    (let ((mean (/ a n)))
         (list mean (sqrt (/ (- b (* n mean mean)) (- n 1)))))
    (let ((x (car v)))
         (loop (cdr v) (+ a x) (+ b (* x x)) (+ n 1))))))

(mean-sdev v)
; (0.9562156817697293 0.5097087109575911)

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5.


Works with: Scheme version R

5

{\displaystyle ^5}

RS
(define (dot-product a b)
  (apply + (map * a b)))

(display (dot-product '(1 3 -5) '(4 -2 -1)))
(newline)

Implement a function to calculate the dot product of two vectors of arbitrary length. The function multiplies corresponding elements from each vector and sums the products. The vectors must be of the same length. Example vectors used are [1, 3, -5] and [4, -2, -1].


Works with: Chicken Scheme(use posix)
(seconds->string (current-seconds))

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


(import (scheme base)
        (scheme write)
        (only (srfi 13) string-delete)
        (only (srfi 14) ->char-set))

;; implementation in plain Scheme
(define (strip-chars str chars)
  (let ((char-list (string->list chars)))
    (define (do-strip str-list result)
      (cond ((null? str-list)
             (reverse result))
            ((member (car str-list) char-list char=?)
             (do-strip (cdr str-list) result))
            (else
              (do-strip (cdr str-list) (cons (car str-list) result)))))
    (list->string
      (do-strip (string->list str) '()))))

(display (strip-chars "She was a soul stripper. She took my heart!" "aei"))
(newline)

;; using functions in SRFI 13 and SRFI 14
(define (strip-chars2 str chars)
  (string-delete (->char-set chars) str))

(display (strip-chars2 "She was a soul stripper. She took my heart!" "aei"))
(newline)

The code defines a function that removes a specified set of characters from a given string. It takes two arguments: the original string and a string of characters to be removed. The function then returns the original string with all instances of the specified characters removed. Two methods are used: one using a basic loop structure, and another utilizing the SRFI libraries to create a character set and delete those characters from the string.


Works with: Chicken Scheme
Works with: Guile
(define (guess)
  (define number (random 11))
  (display "Pick a number from 1 through 10.\n> ")
  (do ((guess (read) (read)))
        ((= guess number) (display "Well guessed!\n"))
      (display "Guess again.\n")))

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


Works with: Gauche Scheme
(map integer->char (iota 26 (char->integer #\a)))

generate a sequence of all lower case ASCII characters from a to z. This is done in a reliable coding style suitable for large programs, using strong typing if available. The code avoids manual enumeration of characters to prevent bugs. It also demonstrates how to access a similar sequence from the standard library if it exists.


(display (number->string 5 2)) (newline)
(display (number->string 50 2)) (newline)
(display (number->string 9000 2)) (newline)

generate a sequence of binary digits for a given non-negative integer. The output displays only the binary digits of each number, followed by a newline, without any whitespace, radix, sign markers, or leading zeros. The conversion can be achieved using built-in radix functions or a user-defined function.


(define earth-radius 6371)
(define pi (acos -1))

(define (distance lat1 long1 lat2 long2)
(define (h a b) (expt (sin (/ (- b a) 2)) 2))
(* 2 earth-radius (asin (sqrt (+ (h lat1 lat2) (* (cos lat1) (cos lat2) (h long1 long2)))))))

(define (deg-to-rad d m s) (* (/ pi 180) (+ d (/ m 60) (/ s 3600))))

(distance (deg-to-rad 36  7.2 0) (deg-to-rad  86 40.2 0)
          (deg-to-rad 33 56.4 0) (deg-to-rad 118 24.0 0))
; 2886.444442837984

Implement a function to calculate the great-circle distance between two points on a sphere using the Haversine formula. The function takes the coordinates of Nashville International Airport (BNA) and Los Angeles International Airport (LAX) as input and returns the distance between them. The calculation uses the recommended earth radius of 6372.8 km or 6371 km, depending on the level of precision required.


Works with: Guile
; Use the regular expression module to parse the url (included with Guile)
(use-modules (ice-9 regex))

; Set the url and parse the hostname, port, and path into variables
(define url "http://www.rosettacode.org/wiki/HTTP")
(define r (make-regexp "^(http://)?([^:/]+)(:)?(([0-9])+)?(/.*)?" regexp/icase))
(define host (match:substring (regexp-exec r url) 2))
(define port (match:substring (regexp-exec r url) 4))
(define path (match:substring (regexp-exec r url) 6))

; Set port to 80 if it wasn't set above and convert from a string to a number
(if (eq? port #f) (define port "80"))
(define port (string->number port))

; Connect to remote host on specified port
(let ((s (socket PF_INET SOCK_STREAM 0)))
        (connect s AF_INET (car (hostent:addr-list (gethostbyname host))) port)

; Send a HTTP request for the specified path
        (display "GET " s)
        (display path s)
        (display " HTTP/1.0\r\n\r\n" s)

; Display the received HTML
        (do ((c (read-char s) (read-char s))) ((eof-object? c))
                (display c)))
Works with: Chicken Scheme

(use http-client)
(print
  (with-input-from-request "http://google.com/"
                           #f read-string))

Accesses and prints the content of a specified URL using the http-client library. Note: This does not handle HTTPS requests.


(define luhn
  (lambda (n)
    (let loop ((number n)
               (index 0)
               (result 0))
      (if (= 0 number)
          (= 0 (remainder result 10))
          (loop (quotient number 10)
                (+ index 1)
                (+ result
                   (if (even? index)
                       (remainder number 10)
                       (let ((part (* 2 (remainder number 10))))
                         (+ (remainder part 10) (quotient part 10))))))))))

The code validates credit card numbers using the Luhn test. It reverses the input number, calculates the sum of odd and even positioned digits (with even digits being doubled and if the result is greater than nine, the digits of the result are summed). If the total sum ends in zero, the number is deemed valid. The code tests this functionality on four given numbers.


(define (string-repeat n str)
  (apply string-append (vector->list (make-vector n str))))

(define (string-repeat n str)
	(fold string-append "" (make-list n str)))
(string-repeat 5 "ha") ==> "hahahahaha"

(make-string 5 #\*)

The code takes a string or a single character and repeats it a specified number of times. For example, it can turn "ha" repeated 5 times into "hahahahaha", or "*" repeated 5 times into "*****". It uses SRFI 1 for repeating a single character.


(define (arithmetic x y)
  (for-each (lambda (op)
              (write  (list op x y))
              (display " => ")
              (write ((eval op) x y))
              (newline))
            '(+ - * / quotient remainder modulo max min gcd lcm)))

(arithmetic 8 12)

 prints this:

(+ 8 12) => 20
(- 8 12) => -4
(* 8 12) => 96
(/ 8 12) => 2/3
(quotient 8 12) => 0
(remainder 8 12) => 8
(modulo 8 12) => 8
(max 8 12) => 12
(min 8 12) => 8
(gcd 8 12) => 4
(lcm 8 12) => 24

take two integers as input, calculate and display their sum, difference, product, integer quotient, remainder, and exponentiation. The quotient is rounded towards zero and the remainder's sign matches the sign of the first operand. The code also includes an example of the `divmod` operator.


Works with: Gauche Scheme
gosh> (use gauche.lazy)
#<undef>
gosh> (length (lrxmatch "th" "the three truths"))
3
gosh> (length (lrxmatch "abab" "ababababab"))
2

The code defines a function to count the number of non-overlapping occurrences of a given substring within a larger string. The function takes two arguments: the main string and the substring to search for. It returns an integer representing the count of non-overlapping occurrences. The function prioritizes the highest number of non-overlapping matches, typically matching from left-to-right or right-to-left.


(define (towers-of-hanoi n from to spare)
  (define (print-move from to)
    (display "Move[")
    (display from)
    (display ", ")
    (display to)
    (display "]")
    (newline))
  (cond ((= n 0) "done")
        (else
         (towers-of-hanoi (- n 1) from spare to)
         (print-move from to)
         (towers-of-hanoi (- n 1) spare to from))))

(towers-of-hanoi 3 "A" "B" "C")

The following codes solve the Towers of Hanoi problem using a recursive process.


Works with: Scheme version R

5

{\displaystyle ^5}

RS
(define (factorial n)
  (define (*factorial n acc)
    (if (zero? n)
        acc
        (*factorial (- n 1) (* acc n))))
  (*factorial n 1))

(define (choose n k)
  (/ (factorial n) (* (factorial k) (factorial (- n k)))))

(display (choose 5 3))
(newline)

"Calculate any binomial coefficient using the provided formula, with specific functionality to output the binomial coefficient of (5,3). The code also includes tasks for combinations, permutations, and their respective versions with replacements, utilizing both direct calculation and recursive methods based on Pascal's Triangle."


(let loop ((i 1))
  (display i)
  (if (positive? (modulo i 6))
      (loop (+ i 1))))

The code initializes a value to 0, then enters a do-while loop where it increments the value by 1 and prints it, continuing as long as the value modulo 6 is not 0. The loop is guaranteed to execute at least once.


Works with: Gauche version 0.8.7 [utf-8,pthreads]

(string-size "Hello world")
Works with: PLT Scheme version 4.2.4
(bytes-length #"Hello world")
Works with: Gauche version 0.8.7 [utf-8,pthreads]

  (string-length "Hello world")

determine the character and byte length of a string, considering different encodings like UTF-8 and UTF-16. The codes handle non-BMP code points correctly and provide the actual character counts in code points, not in code unit counts. The codes also provide the string length in graphemes if possible. The functions used include the Gauche function 'string-size' and the R5RS, R6RS 'string-length' function.


(define (string-top s)
  (if (string=? s "") s (substring s 0 (- (string-length s) 1))))

(define (string-tail s)
  (if (string=? s "") s (substring s 1 (string-length s))))

(define (string-top-tail s)
  (string-tail (string-top s)))

The code demonstrates how to remove the first, last, and both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16, referencing logical characters, not code units. It doesn't necessarily support all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


#!r6rs
(import (rnrs base (6))
        (srfi :27 random-bits))

(define (semireverse li n)
  (define (continue front back n)
    (cond
      ((null? back) front)
      ((zero? n) (cons (car back) (append front (cdr back))))
      (else (continue (cons (car back) front) (cdr back) (- n 1)))))
  (continue '() li n))

(define (shuffle li)
  (if (null? li)
      ()
      (let
          ((li-prime (semireverse li (random-integer (length li)))))
        (cons (car li-prime) (shuffle (cdr li-prime))))))

#!r6rs
(import (rnrs base (6))
        (srfi :27 random-bits))

(define (vector-swap! vec i j)
  (let
      ((temp (vector-ref vec i)))
    (vector-set! vec i (vector-ref vec j))
    (vector-set! vec j temp)))

(define (countdown n)
  (if (zero? n)
      ()
      (cons n (countdown (- n 1)))))

(define (vector-shuffle! vec)
  (for-each
   (lambda (i)
     (let
         ((j (random-integer i)))
       (vector-swap! vec (- i 1) j)))
   (countdown (vector-length vec))))

implement the Knuth shuffle (also known as Fisher-Yates shuffle) algorithm. This algorithm randomly shuffles the elements of an input array in-place, but can be modified to return a new array if necessary. The shuffling process involves iterating through the array from the last index to the first, generating a random integer within the current index range, and swapping the current element with the element at the randomly generated index. The algorithm can also be adjusted to iterate from left to right.


"Display the string 'Goodbye, World!' without appending a newline at the end."


;
; Works with R7RS-compatible Schemes (e.g. Chibi).
; Also current versions of Chicken, Gauche and Kawa.
;
(cond-expand
  (chicken (use srfi-13))
  (gauche  (use srfi-13))
  (kawa    (import (srfi :13)))
  (else    (import (scheme base) (scheme write)))) ; R7RS

(define msg "The quick brown fox jumps over the lazy dog.")
(define key 13)

(define (caesar char)
  (define A (char->integer #\A))
  (define Z (char->integer #\Z))
  (define a (char->integer #\a))
  (define z (char->integer #\z))
  (define c (char->integer char))
  (integer->char
    (cond ((<= A c Z) (+ A (modulo (+ key (- c A)) 26)))
          ((<= a c z) (+ a (modulo (+ key (- c a)) 26)))
          (else c)))) ; Return other characters verbatim.

(display (string-map caesar msg))
(newline)

implement both encoding and decoding functions of a Caesar cipher. The cipher rotates the alphabet letters based on a key ranging from 1 to 25, replacing each letter with the corresponding next letter in the alphabet. The codes also handle cases of wrapping from Z to A. The codes illustrate that Caesar cipher provides minimal security as it is vulnerable to frequency analysis and brute force attacks. The codes also demonstrate that Caesar cipher is identical to Vigenère cipher with a key length of 1 and to Rot-13 with a key of 13.


>(define gcd (lambda (a b)
         (if (zero? b)
             a
             (gcd b (remainder a b)))))
>(define lcm (lambda (a b)
         (if (or (zero? a) (zero? b))
             0
             (abs (* b (floor (/ a (gcd a b))))))))
>(lcm 12 18)
36

calculate the least common multiple (LCM) of two integers m and n. The LCM is the smallest positive integer that has both m and n as factors. If either m or n is zero, the LCM is zero. The LCM can be calculated by iterating all the multiples of m until finding one that is also a multiple of n, or by using the formula lcm(m, n) = |m × n| / gcd(m, n), where gcd is the greatest common divisor. The LCM can also be found by merging the prime decompositions of both m and n.


Works with: Chicken Scheme(define host-info
  (begin
    (display "Endianness: ")
    (display (machine-byte-order))
    (newline)
    (display "Word Size: ")
    (display (if (fixnum? (expt 2 33)) 64 32))
    (newline)))

"Outputs the word size and endianness of the host machine."


(for-each
  (lambda (i) (display i) (newline))
  the_list)

Iterates and prints each element in a collection in order using a "for each" loop or an alternative loop if "for each" is not available.


Works with: Guile
(use-modules (ice-9 regex))
(define s "Hello,How,Are,You,Today")
(define words (map match:substring (list-matches "[^,]+" s)))

(do ((n 0 (+ n 1))) ((= n (length words)))
        (display (list-ref words n))
        (if (< n (- (length words) 1))
                (display ".")))

(define s "Hello,How,Are,You,Today")
(define words (string-tokenize s (char-set-complement (char-set #\,))))
(define t (string-join words "."))
Works with: Gauche Scheme
(print
  (string-join
    (string-split "Hello,How,Are,You,Today" #\,)
    "."))

Tokenizes the string "Hello,How,Are,You,Today" into an array by separating it at commas, and displays the words to the user, separated by a period, including a trailing period.


(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (modulo a b))))

(gcd a b)

find the greatest common divisor (GCD), also known as the greatest common factor (gcf) or greatest common measure, of two integers. It may also relate to finding the least common multiple. The code might utilize a standard function included with Scheme that can take any number of arguments.


Works with: Guile

; Needed in Guile for read-line
(use-modules (ice-9 rdelim))

; Variable used to hold child PID returned from forking
(define child #f)

; Start listening on port 12321 for connections from any address
(let ((s (socket PF_INET SOCK_STREAM 0)))
  (setsockopt s SOL_SOCKET SO_REUSEADDR 1)
  (bind s AF_INET INADDR_ANY 12321)
  (listen s 5) ; Queue size of 5

  (simple-format #t "Listening for clients in pid: ~S" (getpid))
  (newline)

; Wait for connections forever
  (while #t
    (let* ((client-connection (accept s))
        (client-details (cdr client-connection))
        (client (car client-connection)))
; Once something connects fork
      (set! child (primitive-fork))
      (if (zero? child)
      (begin
; Then have child fork to avoid zombie children (grandchildren aren't our responsibility)
        (set! child (primitive-fork))
        (if (zero? child)
          (begin
; Display some connection details
          (simple-format #t "Got new client connection: ~S" client-details)
          (newline)
          (simple-format #t "Client address: ~S"
            (gethostbyaddr (sockaddr:addr client-details)))
          (newline)
; Wait for input from client and then echo the input back forever (or until client quits)
          (do ((line (read-line client)(read-line client))) ((zero? 1))
            (display line client)(newline client))))
; Child exits after spawning grandchild.
        (primitive-exit))
; Parent waits for child to finish spawning grandchild
      (waitpid child)))))

Implement an echo server that listens on TCP port 12321, accepts connections, and echoes back complete lines to clients. The server is designed to handle multiple simultaneous connections and will not stop responding to other clients if one client sends a partial line or stops reading responses. It also logs connection information to standard output. The server only needs to support connections from localhost for testing purposes. The solution may be multi-threaded or multi-process.


(define (numeric? s) (string->number s))

The function checks if a given string can be converted to a numeric value (including floating point and negative numbers) and returns a boolean value accordingly. If the string is not numeric, it returns false, otherwise, it returns true.


Works with: Guile version at least 2.0
Works with: Gauche Scheme version 0.9.12
Works with: CHICKEN Scheme version 5.3.0
Works with: Gambit Scheme version 4.9.4
;;; Sutherland-Hodgman polygon clipping.

(define (evaluate-line x1 y1 x2 y2 x)
  ;; Given the straight line between (x1,y1) and (x2,y2), evaluate it
  ;; at x.
  (let ((dy (- y2 y1))
        (dx (- x2 x1)))
    (let ((slope (/ dy dx))
          (intercept (/ (- (* dx y1) (* dy x1)) dx)))
      (+ (* slope x) intercept))))

(define (intersection-of-lines x1 y1 x2 y2 x3 y3 x4 y4)
  ;; Given the line between (x1,y1) and (x2,y2), and the line between
  ;; (x3,y3) and (x4,y4), find their intersection.
  (cond ((= x1 x2) (list x1 (evaluate-line x3 y3 x4 y4 x1)))
        ((= x3 x4) (list x3 (evaluate-line x1 y1 x2 y2 x3)))
        (else (let ((denominator (- (* (- x1 x2) (- y3 y4))
                                    (* (- y1 y2) (- x3 x4))))
                    (x1*y2-y1*x2 (- (* x1 y2) (* y1 x2)))
                    (x3*y4-y3*x4 (- (* x3 y4) (* y3 x4))))
                (let ((xnumerator (- (* x1*y2-y1*x2 (- x3 x4))
                                     (* (- x1 x2) x3*y4-y3*x4)))
                      (ynumerator (- (* x1*y2-y1*x2 (- y3 y4))
                                     (* (- y1 y2) x3*y4-y3*x4))))
                  (list (/ xnumerator denominator)
                        (/ ynumerator denominator)))))))

(define (intersection-of-edges e1 e2)
  ;;
  ;; A point is a list of two coordinates, and an edge is a list of
  ;; two points.
  ;;
  ;; I am not using any SRFI-9 records, or the like, that define
  ;; actual new types, although I would do so if writing a more
  ;; serious implementation. Also, I am not using any pattern matcher.
  ;; A pattern matcher would make this code less tedious with
  ;; "cadaddaddr" notations.
  (let ((point1 (car e1))
        (point2 (cadr e1))
        (point3 (car e2))
        (point4 (cadr e2)))
    (let ((x1 (car point1))
          (y1 (cadr point1))
          (x2 (car point2))
          (y2 (cadr point2))
          (x3 (car point3))
          (y3 (cadr point3))
          (x4 (car point4))
          (y4 (cadr point4)))
      (intersection-of-lines x1 y1 x2 y2 x3 y3 x4 y4))))

(define (point-is-left-of-edge? pt edge)
  (let ((x (car pt))
        (y (cadr pt))
        (x1 (caar edge))
        (y1 (cadar edge))
        (x2 (caadr edge))
        (y2 (cadadr edge)))
    ;; Outer product of the vectors (x1,y1)-->(x,y) and
    ;; (x1,y1)-->(x2,y2)
    (negative? (- (* (- x x1) (- y2 y1))
                  (* (- x2 x1) (- y y1))))))

(define (clip-subject-edge subject-edge clip-edge accum)
  (define left-of? point-is-left-of-edge?)
  (define (intersection)
    (intersection-of-edges subject-edge clip-edge))
  (let ((s1 (car subject-edge))
        (s2 (cadr subject-edge)))
    (let ((s2-is-inside? (left-of? s2 clip-edge))
          (s1-is-inside? (left-of? s1 clip-edge)))
      (if s2-is-inside?
          (if s1-is-inside?
              (cons s2 accum)
              (cons s2 (cons (intersection) accum)))
          (if s1-is-inside?
              (cons (intersection) accum)
              accum)))))

(define (for-each-subject-edge i subject-points clip-edge accum)
  (define n (vector-length subject-points))
  (if (= i n)
      (list->vector (reverse accum))
      (let ((s2 (vector-ref subject-points i))
            (s1 (vector-ref subject-points
                            (- (if (zero? i) n i) 1))))
        (let ((accum (clip-subject-edge (list s1 s2)
                                        clip-edge accum)))
          (for-each-subject-edge (+ i 1) subject-points
                                 clip-edge accum)))))

(define (for-each-clip-edge i subject-points clip-points)
  (define n (vector-length clip-points))
  (if (= i n)
      subject-points
      (let ((c2 (vector-ref clip-points i))
            (c1 (vector-ref clip-points (- (if (zero? i) n i) 1))))
        (let ((subject-points
               (for-each-subject-edge 0 subject-points
                                      (list c1 c2) '())))
          (for-each-clip-edge (+ i 1) subject-points clip-points)))))

(define (clip subject-points clip-points)
  (for-each-clip-edge 0 subject-points clip-points))

(define (write-eps subject-points clip-points result-points)

  ;; I use only some of the most basic output procedures. Schemes tend
  ;; to include more advanced means to write output, often resembling
  ;; those of Common Lisp.

  (define (x pt) (exact->inexact (car pt)))
  (define (y pt) (exact->inexact (cadr pt)))

  (define (moveto pt)
    (display (x pt))
    (display " ")
    (display (y pt))
    (display " moveto")
    (newline))

  (define (lineto pt)
    (display (x pt))
    (display " ")
    (display (y pt))
    (display " lineto")
    (newline))

  (define (setrgbcolor rgb)
    (display rgb)
    (display " setrgbcolor")
    (newline))

  (define (simple-word word)
    (lambda ()
      (display word)
      (newline)))

  (define closepath (simple-word "closepath"))
  (define fill (simple-word "fill"))
  (define stroke (simple-word "stroke"))
  (define gsave (simple-word "gsave"))
  (define grestore (simple-word "grestore"))

  (define (showpoly poly line-color fill-color)
    (define n (vector-length poly))
    (moveto (vector-ref poly 0))
    (do ((i 1 (+ i 1)))
        ((= i n))
      (lineto (vector-ref poly i)))
    (closepath)
    (setrgbcolor line-color)
    (gsave)
    (setrgbcolor fill-color)
    (fill)
    (grestore)
    (stroke))

  (define (code s)
    (display s)
    (newline))

  (code "%!PS-Adobe-3.0 EPSF-3.0")
  (code "%%BoundingBox: 40 40 360 360")
  (code "0 setlinewidth")
  (showpoly clip-points ".5 0 0" "1 .7 .7")
  (showpoly subject-points "0 .2 .5" ".4 .7 1")
  (code "2 setlinewidth")
  (code "[10 8] 0 setdash")
  (showpoly result-points ".5 0 .5" ".7 .3 .8")
  (code "%%EOF"))

(define (write-eps-to-file outfile subject-points clip-points
                           result-points)
  (with-output-to-file outfile
    (lambda ()
      (write-eps subject-points clip-points result-points))))

(define subject-points
  #((50 150)
    (200 50)
    (350 150)
    (350 300)
    (250 300)
    (200 250)
    (150 350)
    (100 250)
    (100 200)))

(define clip-points
  #((100 100)
    (300 100)
    (300 300)
    (100 300)))

(define result-points (clip subject-points clip-points))

(display result-points)
(newline)
(write-eps-to-file "sutherland-hodgman.eps"
                   subject-points clip-points result-points)
(display "Wrote sutherland-hodgman.eps")
(newline)

Implement the Sutherland-Hodgman polygon clipping algorithm to find the intersection between a given polygon and a rectangle. The code takes a polygon defined by specific points and clips it by a rectangle defined by another set of points. The sequence of points defining the resulting clipped polygon is then printed. Additionally, for extra credit, the code also displays all three polygons on a graphical surface, each in a different color, and fills the resulting polygon. The origin for display can be either north-west or south-west, based on the convenience of the display mechanism.


(define pi (* 4 (atan 1)))

(define radians (/ pi 4))
(define degrees 45)

(display (sin radians))
(display " ")
(display (sin (* degrees (/ pi 180))))
(newline)

(display (cos radians))
(display " ")
(display (cos (* degrees (/ pi 180))))
(newline)

(display (tan radians))
(display " ")
(display (tan (* degrees (/ pi 180))))
(newline)

(define arcsin (asin (sin radians)))
(display arcsin)
(display " ")
(display (* arcsin (/ 180 pi)))
(newline)

(define arccos (acos (cos radians)))
(display arccos)
(display " ")
(display (* arccos (/ 180 pi)))
(newline)

(define arctan (atan (tan radians)))
(display arctan)
(display " ")
(display (* arctan (/ 180 pi)))
(newline)

demonstrate the usage of trigonometric functions (sine, cosine, tangent, and their inverses) with the same angle in both radians and degrees. It also includes the conversion of the results of inverse functions to radians and degrees. If the language lacks these functions, the code calculates them using known approximations or identities.


(number->string (+ 1 (string->number "1234")))


(define (median l)
  (* (+ (list-ref (bubble-sort l >) (round (/ (- (length l) 1) 2)))
        (list-ref (bubble-sort l >) (round (/ (length l) 2)))) 0.5))

(define (median l)
  (* (+ (list-ref (sort l less?) (round (/ (- (length l) 1) 2)))
        (list-ref (sort l less?) (round (/ (length l) 2)))) 0.5))

The code calculates the median value of a vector of floating-point numbers, handling cases with even numbers of elements by returning the average of the two middle values. It uses the selection algorithm for efficiency. It also includes tasks for calculating various statistical measures such as mean, mode, and standard deviation. The code utilizes Rosetta Code's bubble-sort function and SRFI-95.


(do ((i 1 (+ i 1)))
    ((> i 100))
    (display
      (cond ((= 0 (modulo i 15)) "FizzBuzz")
            ((= 0 (modulo i 3))  "Fizz")
            ((= 0 (modulo i 5))  "Buzz")
            (else                i)))
    (newline))

(define (fizzbuzz x y)
  (println
    (cond (( = (modulo x 15) 0 ) "FizzBuzz")
          (( = (modulo x 3) 0 ) "Fizz")
          (( = (modulo x 5) 0 ) "Buzz")
          (else x)))

    (if (< x y) (fizzbuzz (+ x 1) y)))

(fizzbuzz 1 100)

(define (fizzbuzz x)
  (let ([words '((3 . "Fizz")
                 (5 . "Buzz"))])
    (define (fbm x)
      (let ([w (map cdr (filter (lambda (wo) (= 0 (modulo x (car wo)))) words))])
        (if (null? w) x (apply string-append w))))
    (for-each (cut format #t "~a~%" <>) (map fbm (iota x 1 1)))))

(fizzbuzz 15)

"Output integers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'. The code uses a recursive procedure and implements maps and filters for easier modification but less readability."


(define x-centre -0.5)
(define y-centre 0.0)
(define width 4.0)
(define i-max 800)
(define j-max 600)
(define n 100)
(define r-max 2.0)
(define file "out.pgm")
(define colour-max 255)
(define pixel-size (/ width i-max))
(define x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
(define y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))

(define (inside? z)
  (define (*inside? z-0 z n)
    (and (< (magnitude z) r-max)
         (or (= n 0)
             (*inside? z-0 (+ (* z z) z-0) (- n 1)))))
  (*inside? z 0 n))

(define (boolean->integer b)
  (if b colour-max 0))

(define (pixel i j)
  (boolean->integer
    (inside?
      (make-rectangular (+ x-offset (* pixel-size i))
                        (- y-offset (* pixel-size j))))))

(define (plot)
  (with-output-to-file file
    (lambda ()
      (begin (display "P2") (newline)
             (display i-max) (newline)
             (display j-max) (newline)
             (display colour-max) (newline)
             (do ((j 1 (+ j 1))) ((> j j-max))
                 (do ((i 1 (+ i 1))) ((> i i-max))
                     (begin (display (pixel i j)) (newline))))))))

(plot)Works with: CHICKEN Scheme version 5.3.0

;; A program written for CHICKEN Scheme version 5.3.0 and various
;; eggs.

(import (r7rs))
(import (scheme base))
(import (scheme case-lambda))
(import (scheme inexact))

(import (prefix sdl2 "sdl2:"))
(import (prefix imlib2 "imlib2:"))

(import (format))
(import (matchable))
(import (simple-exceptions))

(define sdl2-subsystems-used '(events video))

;; ------------------------------
;; Basics for using the sdl2 egg:
(sdl2:set-main-ready!)
(sdl2:init! sdl2-subsystems-used)
(on-exit sdl2:quit!)
(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (sdl2:quit!)
     (original-handler exception))))
;; ------------------------------

(define-record-type <mandel-params>
  (%%make-mandel-params)
  mandel-params?
  (window ref-window set-window!)
  (xcenter ref-xcenter set-xcenter!)
  (ycenter ref-ycenter set-ycenter!)
  (pixels-per-unit ref-pixels-per-unit set-pixels-per-unit!)
  (pixels-per-event-check ref-pixels-per-event-check
                          set-pixels-per-event-check!)
  (max-escape-time ref-max-escape-time set-max-escape-time!))

(define initial-width                   400)
(define initial-height                  400)
(define initial-xcenter                -3/4)
(define initial-ycenter                 0)
(define initial-pixels-per-unit         150)
(define initial-pixels-per-event-check  1000)
(define initial-max-escape-time         1000)

(define (make-mandel-params window)
  (let ((params (%%make-mandel-params)))
    (set-window! params window)
    (set-xcenter! params initial-xcenter)
    (set-ycenter! params initial-ycenter)
    (set-pixels-per-unit! params initial-pixels-per-unit)
    (set-pixels-per-event-check! params
                                 initial-pixels-per-event-check)
    (set-max-escape-time! params initial-max-escape-time)
    params))

(define window (sdl2:create-window! "mandelbrot set task"
                                    'centered 'centered
                                    initial-width initial-height
                                    '()))
(define params (make-mandel-params window))

(define empty-color (sdl2:make-color 200 200 200))

(define (clear-mandel!)
  (sdl2:fill-rect! (sdl2:window-surface (ref-window params))
                   #f empty-color)
  (sdl2:update-window-surface! window))

(define drawing? #t)
(define redraw? #f)

(define (draw-mandel! event-checker)
  (clear-mandel!)
  (let repeat ()
    (let*-values
        (((window) (ref-window params))
         ((width height) (sdl2:window-size window)))
      (let* ((xcenter (ref-xcenter params))
             (ycenter (ref-ycenter params))
             (pixels-per-unit (ref-pixels-per-unit params))
             (pixels-per-event-check
              (ref-pixels-per-event-check params))
             (max-escape-time (ref-max-escape-time params))
             (step (/ 1.0 pixels-per-unit))
             (xleft (- xcenter (/ width (* 2.0 pixels-per-unit))))
             (ytop (+ ycenter (/ height (* 2.0 pixels-per-unit))))
             (pixel-count 0))
        (do ((j 0 (+ j 1))
             (cy ytop (- cy step)))
            ((= j height))
          (do ((i 0 (+ i 1))
               (cx xleft (+ cx step)))
              ((= i width))
            (let* ((color (compute-color-by-escape-time-algorithm
                           cx cy max-escape-time)))
              (sdl2:surface-set! (sdl2:window-surface window)
                                 i j color)
              (if (= pixel-count pixels-per-event-check)
                  (let ((event-checker (call/cc event-checker)))
                    (cond (redraw?
                           (set! redraw? #f)
                           (clear-mandel!)
                           (repeat)))
                    (set! pixel-count 0))
                  (set! pixel-count (+ pixel-count 1)))))
          ;; Display a row.
          (sdl2:update-window-surface! window))))
    (set! drawing? #f)
    (repeat)))

(define (compute-color-by-escape-time-algorithm
         cx cy max-escape-time)
  (escape-time->color (compute-escape-time cx cy max-escape-time)
                      max-escape-time))

(define (compute-escape-time cx cy max-escape-time)
  (let loop ((x 0.0)
             (y 0.0)
             (iter 0))
    (if (= iter max-escape-time)
        iter
        (let ((xsquared (* x x))
              (ysquared (* y y)))
          (if (< 4 (+ xsquared ysquared))
              iter
              (let ((x (+ cx (- xsquared ysquared)))
                    (y (+ cy (* (+ x x) y))))
                (loop x y (+ iter 1))))))))

(define (escape-time->color escape-time max-escape-time)
  ;; This is a very naive and ad hoc algorithm for choosing colors,
  ;; but hopefully will suffice for the task. With this algorithm, at
  ;; least one can zoom in and see some of the fractal-like structures
  ;; out on the filaments.
  (let* ((initial-ppu initial-pixels-per-unit)
         (ppu (ref-pixels-per-unit params))
         (fraction (* (/ (log escape-time) (log max-escape-time))))
         (fraction (if (= fraction 1.0)
                       fraction
                       (* fraction
                          (/ (log initial-ppu)
                             (log (max initial-ppu (* 0.05 ppu)))))))
         (value (- 255 (min 255 (exact-rounded (* fraction 255))))))
    (sdl2:make-color value value value)))

(define (exact-rounded x)
  (exact (round x)))

(define (event-loop)
  (define event (sdl2:make-event))
  (define painter draw-mandel!)
  (define zoom-ratio 2)

  (define (recenter! xcoord ycoord)
    (let*-values
        (((window) (ref-window params))
         ((width height) (sdl2:window-size window))
         ((ppu) (ref-pixels-per-unit params)))
      (set-xcenter! params
                    (+ (ref-xcenter params)
                       (/ (- (* 2.0 xcoord) width) (* 2.0 ppu))))
      (set-ycenter! params
                    (+ (ref-ycenter params)
                       (/ (- height (* 2.0 ycoord)) (* 2.0 ppu))))))

  (define (zoom-in!)
    (let* ((ppu (ref-pixels-per-unit params))
           (ppu (* ppu zoom-ratio)))
      (set-pixels-per-unit! params ppu)))

  (define (zoom-out!)
    (let* ((ppu (ref-pixels-per-unit params))
           (ppu (* (/ 1.0 zoom-ratio) ppu)))
      (set-pixels-per-unit! params (max 1 ppu))))

  (define (restore-original-settings!)
    (set-xcenter! params initial-xcenter)
    (set-ycenter! params initial-ycenter)
    (set-pixels-per-unit! params initial-pixels-per-unit)
    (set-pixels-per-event-check!
     params initial-pixels-per-event-check)
    (set-max-escape-time! params initial-max-escape-time)
    (set! zoom-ratio 2))

  (define dump-image!            ; Really this should put up a dialog.
    (let ((dump-number 1))
      (lambda ()
        (let*-values
            (((window) (ref-window params))
             ((width height) (sdl2:window-size window))
             ((surface) (sdl2:window-surface window)))
          (let ((filename (string-append "mandelbrot-image-"
                                         (number->string dump-number)
                                         ".png"))
                (img (imlib2:image-create width height)))
            (do ((j 0 (+ j 1)))
                ((= j height))
              (do ((i 0 (+ i 1)))
                  ((= i width))
                (let-values
                    (((r g b a) (sdl2:color->values
                                 (sdl2:surface-ref surface i j))))
                  (imlib2:image-draw-pixel
                   img (imlib2:color/rgba r g b a) i j))))
            (imlib2:image-alpha-set! img #f)
            (imlib2:image-save img filename)
            (format #t "~a written~%" filename)
            (set! dump-number (+ dump-number 1)))))))

  (let loop ()
    (when redraw?
      (set! drawing? #t))
    (when drawing?
      (set! painter (call/cc painter)))
    (set! redraw? #f)
    (if (not (sdl2:poll-event! event))
        (loop)
        (begin
          (match (sdl2:event-type event)
            ('quit)                     ; Quit by leaving the loop.
            ('window
             (match (sdl2:window-event-event event)
               ;; It should be possible to resize the window, but I
               ;; have not yet figured out how to do this with SDL2
               ;; and not crash sometimes.
               ((or 'exposed 'restored)
                (sdl2:update-window-surface! (ref-window params))
                (loop))
               (_ (loop))))
            ('mouse-button-down
             (recenter! (sdl2:mouse-button-event-x event)
                        (sdl2:mouse-button-event-y event))
             (set! redraw? #t)
             (loop))
            ('key-down
             (match (sdl2:keyboard-event-sym event)
               ('q 'quit-by-leaving-the-loop)
               ((or 'plus 'kp-plus)
                (zoom-in!)
                (set! redraw? #t)
                (loop))
               ((or 'minus 'kp-minus)
                (zoom-out!)
                (set! redraw? #t)
                (loop))
               ((or 'n-2 'kp-2)
                (set! zoom-ratio 2)
                (loop))
               ((or 'n-3 'kp-3)
                (set! zoom-ratio 3)
                (loop))
               ((or 'n-4 'kp-4)
                (set! zoom-ratio 4)
                (loop))
               ((or 'n-5 'kp-5)
                (set! zoom-ratio 5)
                (loop))
               ((or 'n-6 'kp-6)
                (set! zoom-ratio 6)
                (loop))
               ((or 'n-7 'kp-7)
                (set! zoom-ratio 7)
                (loop))
               ((or 'n-8 'kp-8)
                (set! zoom-ratio 8)
                (loop))
               ((or 'n-9 'kp-9)
                (set! zoom-ratio 9)
                (loop))
               ('o
                (restore-original-settings!)
                (set! redraw? #t)
                (loop))
               ('p
                (dump-image!)
                (loop))
               (some-key-in-which-we-are-not-interested
                (loop))))
            (some-event-in-which-we-are-not-interested
             (loop)))))))

;; At the least this legend should go in a window, but printing it to
;; the terminal will, hopefully, suffice for the task.
(format #t "~%~8tACTIONS~%")
(format #t "~8t-------~%")
(define fmt "~2t~a~15t: ~a~%")
(format #t fmt "Q key" "quit")
(format #t fmt "mouse button" "recenter")
(format #t fmt "+ key" "zoom in")
(format #t fmt "- key" "zoom in")
(format #t fmt "2 .. 9 key" "set zoom ratio")
(format #t fmt "O key" "restore original")
(format #t fmt "P key" "dump to a PNG")
(format #t "~%")

(event-loop)

The code generates and draws the Mandelbrot set, using specific algorithms and functions. It writes the image of the Mandelbrot set to a plain pgm file, with the set drawn in white and the exterior in black. The code requires several CHICKEN "eggs" and can be compiled with csc -O3 mandelbrot_task_CHICKEN.scm. It also provides an example of a PNG dumped by the program during a zoom-in operation.


(apply + '(1 2 3 4 5))
(apply * '(1 2 3 4 5))

(define (reduce f i l)
  (if (null? l)
    i
    (reduce f (f i (car l)) (cdr l))))

(reduce + 0 '(1 2 3 4 5)) ;; 0 is unit for +
(reduce * 1 '(1 2 3 4 5)) ;; 1 is unit for *

calculate the sum and product of an array of integers using a tail-recursive solution in Scheme, leveraging tail call optimization for space efficiency.


(define (leap-year? n)
(apply (lambda (a b c) (or a (and (not b) c)))
       (map (lambda (m) (zero? (remainder n m)))
            '(400 100 4))))

"Determines if a specified year is a leap year in the Gregorian calendar."


"Implements functionality to copy a string's content and create an additional reference to an existing string where applicable."


implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. The functions are defined such that F(0) = 1, M(0) = 0, F(n) = n - M(F(n-1)) for n > 0, and M(n) = n - F(M(n-1)) for n > 0. If the programming language does not support mutual recursion, this should be stated instead of providing an alternative solution. The functions are defined within a letrec block to enable mutual recursion.


(define (binary-search value vector)
  (let helper ((low 0)
               (high (- (vector-length vector) 1)))
    (if (< high low)
        #f
        (let ((middle (quotient (+ low high) 2)))
          (cond ((> (vector-ref vector middle) value)
                 (helper low (- middle 1)))
                ((< (vector-ref vector middle) value)
                 (helper (+ middle 1) high))
                (else middle))))))

> (binary-search 6 '#(1 3 4 5 6 7 8 9 10))
4
> (binary-search 2 '#(1 3 4 5 6 7 8 9 10))
#f

Code summarization: The given code implements a binary search algorithm, which can be either recursive or iterative. The algorithm searches for a specific "secret value" within a sorted integer array, starting from a specified range. It returns the index of the secret value if found, or indicates its absence. The code also handles multiple equal values and potential overflow bugs. Additionally, it provides variations of the algorithm to find the leftmost and rightmost insertion points for the secret value.


 (define (main args)
  (for-each (lambda (arg) (display arg) (newline)) args))

The code retrieves and prints the list of command-line arguments provided to the program, such as 'myprogram -c "alpha beta" -h "gamma"'. It also includes functionalities for intelligent parsing of these arguments.


Library: Scheme/PsTk
#!r6rs

;;; R6RS implementation of Pendulum Animation

(import (rnrs)
        (lib pstk main) ; change this for your pstk installation
        )

(define PI 3.14159)
(define *conv-radians* (/ PI 180))
(define *theta* 45.0)
(define *d-theta* 0.0)
(define *length* 150)
(define *home-x* 160)
(define *home-y* 25)

;;; estimates new angle of pendulum
(define (recompute-angle)
  (define (avg a b) (/ (+ a b) 2))
  (let* ((scaling (/ 3000.0 (* *length* *length*)))
         ; first estimate
         (first-dd-theta (- (* (sin (* *theta* *conv-radians*)) scaling)))
         (mid-d-theta (+ *d-theta* first-dd-theta))
         (mid-theta (+ *theta* (avg *d-theta* mid-d-theta)))
         ; second estimate
         (mid-dd-theta (- (* (sin (* mid-theta *conv-radians*)) scaling)))
         (mid-d-theta-2 (+ *d-theta* (avg first-dd-theta mid-dd-theta)))
         (mid-theta-2 (+ *theta* (avg *d-theta* mid-d-theta-2)))
         ; again first
         (mid-dd-theta-2 (- (* (sin (* mid-theta-2 *conv-radians*)) scaling)))
         (last-d-theta (+ mid-d-theta-2 mid-dd-theta-2))
         (last-theta (+ mid-theta-2 (avg mid-d-theta-2 last-d-theta)))
         ; again second
         (last-dd-theta (- (* (sin (* last-theta *conv-radians*)) scaling)))
         (last-d-theta-2 (+ mid-d-theta-2 (avg mid-dd-theta-2 last-dd-theta)))
         (last-theta-2 (+ mid-theta-2 (avg mid-d-theta-2 last-d-theta-2))))
    ; put values back in globals
    (set! *d-theta* last-d-theta-2)
    (set! *theta* last-theta-2)))

;;; The main event loop and graphics context
(let ((tk (tk-start)))
  (tk/wm 'title tk "Pendulum Animation")
  (let ((canvas (tk 'create-widget 'canvas)))

    ;;; redraw the pendulum on canvas
    ;;; - uses angle and length to compute new (x,y) position of bob
    (define (show-pendulum canvas)
      (let* ((pendulum-angle (* *conv-radians* *theta*))
             (x (+ *home-x* (* *length* (sin pendulum-angle))))
             (y (+ *home-y* (* *length* (cos pendulum-angle)))))
        (canvas 'coords 'rod *home-x* *home-y* x y)
        (canvas 'coords 'bob (- x 15) (- y 15) (+ x 15) (+ y 15))))

    ;;; move the pendulum and repeat after 20ms
    (define (animate)
      (recompute-angle)
      (show-pendulum canvas)
      (tk/after 20 animate))

    ;; layout the canvas
    (tk/grid canvas 'column: 0 'row: 0)
    (canvas 'create 'line 0 25 320 25 'tags: 'plate 'width: 2 'fill: 'grey50)
    (canvas 'create 'oval 155 20 165 30 'tags: 'pivot 'outline: "" 'fill: 'grey50)
    (canvas 'create 'line 1 1 1 1 'tags: 'rod 'width: 3 'fill: 'black)
    (canvas 'create 'oval 1 1 2 2 'tags: 'bob 'outline: 'black 'fill: 'yellow)

    ;; get everything started
    (show-pendulum canvas)
    (tk/after 500 animate)
    (tk-event-loop tk)))

#!/usr/bin/env gosh
#| -*- mode: scheme; coding: utf-8; -*- |#
(use gl)
(use gl.glut)
(use gl.simple.viewer)
(use math.const)
(define (deg->rad degree) (* (/ degree 180) pi))
(define (rad->deg radians) (* (/ radians pi) 180))
(define (main args)
  (glut-init args)
  (let* ((φ (deg->rad 179)) (l 0.5) (bob 0.02) (q (make <glu-quadric>))
	 (draw-pendulum (lambda()
  			  (gl-push-matrix*
			   (gl-scale 4 4 4)
			   (gl-translate 0 l 0)
			   (gl-rotate (rad->deg φ) 0 0 1)
			   (gl-begin GL_LINES)
			   (gl-vertex 0 0)
			   (gl-vertex 0 (- l))
			   (gl-end)
			   (gl-translate 0 (- l) 0)
			   (glu-sphere q bob 10 10))))
	 (g 9.81)
	 (φ̇ 0)
	 (euler-step (lambda(h)
		       (inc! φ̇ (* (- (* (/ g l) (sin φ))) h))
		       (inc! φ (* φ̇ h)))))
    (simple-viewer-display
     (lambda ()
       ;; I hope sync to VBLANK aka VSYNC works and the display has ~60Hz
       (euler-step 1/60)
       (draw-pendulum)
       (glut-post-redisplay))))
  (simple-viewer-window 'pendulum)
  (glut-full-screen)
  (simple-viewer-run :rescue-errors #f))

simulate and animate a simple gravity pendulum using a physical model. The animation is created using Scheme + PS/Tk, based on a direct translation from the Ruby/Tk example. An alternative version uses gauche scheme.


Works with: Chicken Scheme
Using the json egg: (use json)
(define object-example
  (with-input-from-string "{\"foo\": \"bar\", \"baz\": [1, 2, 3]}"
                          json-read))
(pp object-example)
; this prints #(("foo" . "bar") ("baz" 1 2 3))

(json-write #([foo . bar]
              [baz   1 2 3]
              [qux . #((rosetta . code))]))
; this writes the following:
; {"foo": "bar", "baz": [1, 2, 3], "qux": {"foo": "bar"}}

"Load a JSON string into a data structure, create a new data structure, serialize it into JSON, and validate the JSON."


(define (root number degree tolerance)
  (define (good-enough? next guess)
    (< (abs (- next guess)) tolerance))
  (define (improve guess)
    (/ (+ (* (- degree 1) guess) (/ number (expt guess (- degree 1)))) degree))
  (define (*root guess)
    (let ((next (improve guess)))
      (if (good-enough? next guess)
          guess
          (*root next))))
  (*root 1.0))

(display (root (expt 2 10) 10 0.1))
(newline)
(display (root (expt 2 10) 10 0.01))
(newline)
(display (root (expt 2 10) 10 0.001))
(newline)

2.04732932236839
2.00463204835482
2.00004786858167

implement the principal nth root computation algorithm for a positive real number A.


Works with: Chicken Scheme
(use posix)
(get-host-name)

Works with: Guile
(gethostname)

"Determines and outputs the hostname of the current system where the routine is running."


Works with: PLT Scheme version 4

#lang scheme
(require srfi/27 srfi/1) ;; random-integer, every

(define (play)
  (let* ([numbers (build-list 4 (lambda (n)
                                  (add1 (random-integer 9))))]
         [valid?  (curryr valid? numbers)])
    (printf startup-message numbers)
    (let loop ([exp (read)])
      (with-handlers ([exn:fail? (lambda (err)
                                   (printf error-message exp (exn-message err))
                                   (loop (read)))])
       (cond [(eq? exp '!) (play)]

             [(or (eq? exp 'q)
                  (eof-object? exp)) (printf quit-message)]

             [(not (valid? exp))
              (printf bad-exp-message exp)
              (loop (read))]

             [(not (= (eval exp) 24))
              (printf bad-result-message exp (eval exp))
              (loop (read))]

             [else (printf winning-message)])))))

(define (valid? exp numbers)
  ;; must contain each number exactly once and only valid symbols
  (define (valid-symbol? sym)
    ;; only +, -, *, and / are valid
    (case sym
      [(+ - * /) #t]
      [else #f]))

  (let* ([ls (flatten exp)]
         [numbers* (filter number? ls)]
         [symbols  (remove number? ls)])
    (and (equal? (sort numbers <)
                 (sort numbers* <))
         (every valid-symbol? symbols))))

(define startup-message "
Write a lisp expression that evaluates to 24
using only (, ), +, -, *, /
and these four numbers: ~a

or '!' to get a new set of numbers
or 'q' to quit")

(define error-message "
Your expression ~a raised an exception:

  \"~a\"

Please try again")

(define bad-exp-message "Sorry, ~a is a bad expression.")
(define bad-result-message "Sorry, ~a evaluates to ~a, not 24.")
(define quit-message "Thanks for playing...")
(define winning-message "You win!")

(provide play)

The code generates four random digits from 1 to 9 and prompts the user to form an arithmetic expression using these digits exactly once, with the aim to achieve a total of 24. The code checks and evaluates the user's input expression, allowing operations of addition, subtraction, multiplication, and division (with remainders preserved). The code does not allow the formation of multiple-digit numbers from the provided digits. The order of the digits does not need to be preserved in the expression. The code does not generate or test the validity of the expression.


(define (run-length-decode v)
   (apply string-append (map (lambda (p) (make-string (car p) (cdr p))) v)))

(define (run-length-encode s)
(let ((n (string-length s)))
(let loop ((i (- n 2)) (c (string-ref s (- n 1))) (k 1) (v '()))
(if (negative? i) (cons (cons k c) v)
    (let ((x (string-ref s i)))
    (if (char=? c x) (loop (- i 1) c (+ k 1) v)
                     (loop (- i 1) x 1 (cons (cons k c) v))))))))

(run-length-encode "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW")
; ((12 . #\W) (1 . #\B) (12 . #\W) (3 . #\B) (24 . #\W) (1 . #\B) (14 . #\W))
(run-length-decode '((12 . #\W) (1 . #\B) (12 . #\W) (3 . #\B) (24 . #\W) (1 . #\B) (14 . #\W)))
; "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"

implement a run-length encoding and decoding system for strings containing uppercase characters. The system compresses repeated characters by storing the length of the run and provides a function to reverse the compression.


(define s "hello")
(display (string-append s " literal"))
(newline)
(define s1 (string-append s " literal"))
(display s1)
(newline)

Initializes two string variables, one with a text value and the other as a concatenation of the first variable and a string literal, then displays their content.


(import (scheme base)
        (scheme char)
        (scheme file)
        (scheme write)
        (srfi 125)  ; hash tables
        (srfi 132)) ; sorting library

;; read in the words
(define (read-groups)
  (with-input-from-file
    "unixdict.txt"
    (lambda ()
      (let ((groups (hash-table string=?)))
        (do ((line (read-line) (read-line)))
          ((eof-object? line) groups)
          (let* ((key (list->string (list-sort char<? (string->list line))))
                 (val (hash-table-ref/default groups key '())))
            (hash-table-set! groups key (cons line val))))))))

;; extract the longest values from given hash-table of groups
(define (largest-groups groups)
  (define (find-largest grps n sofar)
    (cond ((null? grps)
           sofar)
          ((> (length (car grps)) n)
           (find-largest (cdr grps) (length (car grps)) (list (car grps))))
          ((= (length (car grps)) n)
           (find-largest (cdr grps) n (cons (car grps) sofar)))
          (else
            (find-largest (cdr grps) n sofar))))
  (find-largest (hash-table-values groups) 0 '()))

;; print results
(for-each
  (lambda (group)
    (display "[ ")
    (for-each (lambda (word) (display word) (display " ")) group)
    (display "]\n"))
  (list-sort (lambda (a b) (string<? (car a) (car b)))
             (map (lambda (grp) (list-sort string<? grp))
                  (largest-groups (read-groups)))))

The code identifies sets of words that are anagrams, using the word list from http://wiki.puzzlers.org/pub/wordlists/unixdict.txt. It utilizes SRFI 125 for hash tables and SRFI 132 for sorting to find the sets with the most words.


(define (carpet n)
  (define (in-carpet? x y)
    (cond ((or (zero? x) (zero? y))
              #t)
          ((and (= 1 (remainder x 3)) (= 1 (remainder y 3)))
              #f)
          (else
              (in-carpet? (quotient x 3) (quotient y 3)))))

  (do ((i 0 (+ i 1))) ((not (< i (expt 3 n))))
    (do ((j 0 (+ j 1))) ((not (< j (expt 3 n))))
      (display (if (in-carpet? i j)
                   #\*
                   #\space)))
    (newline)))

generate a graphical or ASCII-art representation of a Sierpinski carpet of a given order N. The representation uses whitespace and non-whitespace characters, with the non-whitespace character not strictly required to be '#'. The placement of these characters follows the pattern of a Sierpinski carpet.


(define (char-freq port table)
  (if
   (eof-object? (peek-char port))
   table
   (char-freq port (add-char (read-char port) table))))

(define (add-char char table)
  (cond
   ((null? table) (list (list char 1)))
   ((eq? (caar table) char) (cons (list char (+ (cadar table) 1)) (cdr table)))
   (#t (cons (car table) (add-char char (cdr table))))))

(define (nodeify table)
  (map (lambda (x) (list x '() '())) table))

(define node-freq cadar)

(define (huffman-tree nodes)
  (let ((queue (sort nodes (lambda (x y) (< (node-freq x) (node-freq y))))))
    (if
     (null? (cdr queue))
     (car queue)
     (huffman-tree
      (cons
       (list
        (list 'notleaf (+ (node-freq (car queue)) (node-freq (cadr queue))))
        (car queue)
        (cadr queue))
       (cddr queue))))))

(define (list-encodings tree chars)
  (for-each (lambda (c) (format #t "~a:~a~%" c (encode c tree))) chars))

(define (encode char tree)
  (cond
   ((null? tree) #f)
   ((eq? (caar tree) char) '())
   (#t
    (let ((left (encode char (cadr tree))) (right (encode char (caddr tree))))
      (cond
       ((not (or left right)) #f)
       (left (cons #\1 left))
       (right (cons #\0 right)))))))

(define (decode digits tree)
  (cond
   ((not (eq? (caar tree) 'notleaf)) (caar tree))
   ((eq? (car digits) #\0) (decode (cdr digits) (cadr tree)))
   (#t (decode (cdr digits) (caddr tree)))))

(define input "this is an example for huffman encoding")
(define freq-table (char-freq (open-input-string input) '()))
(define tree (huffman-tree (nodeify freq-table)))
(list-encodings tree (map car freq-table))

The code generates a Huffman encoding for each character in the given string "this is an example for huffman encoding". It first creates a tree of nodes based on the frequency of each character. Then, it traverses the tree from root to leaves, assigning '0' for one branch and '1' for the other at each node. The accumulated zeros and ones at each leaf constitute a Huffman encoding for those characters. The output is a table of Huffman encodings for each character.


Library: SQLite

(use sql-de-lite)

(define *db* (open-database "addresses"))

(exec ; create and run the SQL statement
  (sql *db*
       "CREATE TABLE address (
        addrID     INTEGER PRIMARY KEY AUTOINCREMENT,
        addrStreet TEXT NOT NULL,
        addrCity   TEXT NOT NULL,
        addrState  TEXT NOT NULL,
        addrZIP    TEXT NOT NULL
    )"
))

(close-database *db*) ; finally, close database

Create a table in a database to store US postal addresses, including fields for unique identifier, street address, city, state code, and zipcode. The code also demonstrates how to open a database connection in non-database languages.


The code performs a countdown from 10 to 0 using a downward for loop.


(do ((i 2 (+ i 2)))  ; list of variables, initials and steps -- you can iterate over several at once
  ((>= i 9))         ; exit condition
  (display i)        ; body
  (newline))

(let loop ((i 2))            ; function name, parameters and starting values
  (cond ((< i 9)
         (display i)
         (newline)
         (loop (+ i 2))))))  ; tail-recursive call, won't create a new stack frame

(define (for-loop start end step func)
  (let loop ((i start))
    (cond ((< i end)
	   (func i)
	   (loop (+ i step))))))

(for-loop 2 9 2
  (lambda (i)
    (display i)
    (newline)))

(define-syntax for-loop
  (syntax-rules ()
    ((for-loop index start end step body ...)
     (let ((evaluated-end end) (evaluated-step step))
       (let loop ((i start))
         (if (< i evaluated-end)
           ((lambda (index) body ... (loop (+ i evaluated-step))) i)))))))

(for-loop i 2 9 2
  (display i)
  (newline))

demonstrate a for-loop with a step-value greater than one, using the built-in 'do' form in Scheme. It also shows the use of the more flexible 'named let' form. Additionally, it illustrates how to add to the language by wrapping the loop in a function or a macro, making the lambda implicit.


(define-syntax sum
  (syntax-rules ()
    ((sum var low high . body)
     (let loop ((var low)
                (result 0))
       (if (> var high)
           result
           (loop (+ var 1)
                 (+ result . body)))))))

(exact->inexact (sum i 1 100 (/ 1 i)))
5.18737751763962

The code is an implementation of Jensen's Device, a programming technique devised by Jørn Jensen. It uses the call by name method to compute the 100th harmonic number. The technique relies on the re-evaluation of an expression passed as an actual parameter every time the formal parameter's value is needed. This implementation also demonstrates the importance of passing the first parameter by name or reference to ensure changes made within the sum are visible in the caller's context.


continuously calculate and display the next decimal digit of Pi, starting from 3.14159265, until the user aborts the operation. The task is about calculating Pi, not using built-in constants.


(define (lex<? a b)
        (cond ((null? b) #f)
              ((null? a) #t)
              ((= (car a) (car b)) (lex<? (cdr a) (cdr b)))
              (else (< (car a) (car b)))))

"Function to compare and order two numerical lists lexicographically, returning true if the first list should be ordered before the second, and false otherwise."


(define (A m n)
    (cond
        ((= m 0) (+ n 1))
        ((= n 0) (A (- m 1) 1))
        (else (A (- m 1) (A m (- n 1))))))

(define (A m n)
  (letrec ((A-stream
    (cons-stream
      (ints-from 1) ;; m = 0
      (cons-stream
        (ints-from 2) ;; m = 1
        (cons-stream
          ;; m = 2
          (stream-map (lambda (n)
                        (1+ (* 2 (1+ n))))
                      (ints-from 0))
          (cons-stream
            ;; m = 3
            (stream-map (lambda (n)
                          (- (knuth-up-arrow 2 (- m 2) (+ n 3)) 3))
                        (ints-from 0))
             ;; m = 4...
            (stream-tail A-stream 3)))))))
    (stream-ref (stream-ref A-stream m) n)))

(define (ints-from n)
  (letrec ((ints-rec (cons-stream n (stream-map 1+ ints-rec))))
    ints-rec))

(define (knuth-up-arrow a n b)
  (let loop ((n n) (b b))
    (cond ((= b 0) 1)
          ((= n 1) (expt a b))
          (else    (loop (-1+ n) (loop n (-1+ b)))))))

Implement the Ackermann function, a non-primitive recursive function that takes two non-negative arguments and returns a rapidly growing value. The function should handle arbitrary precision if possible.


implement the Gamma function using either the Lanczos or Stirling's approximation. The codes also compare the results of the custom implementation with the built-in/library function if available. The Gamma function is computed through numerical integration.


(import (scheme base)
        (scheme write)
        (srfi 1))

;; return list of solutions to n-queens problem
(define (n-queens n) ; breadth-first solution
  (define (place-initial-row) ; puts a queen on each column of row 0
    (list-tabulate n (lambda (col) (list (cons 0 col)))))
  (define (place-on-row soln-so-far row)
    (define (invalid? col)
      (any (lambda (posn)
             (or (= col (cdr posn)) ; on same column
                 (= (abs (- row (car posn))) ; on same diagonal
                    (abs (- col (cdr posn))))))
           soln-so-far))
    ;
    (do ((col 0 (+ 1 col))
         (res '() (if (invalid? col)
                    res
                    (cons (cons (cons row col) soln-so-far)
                          res))))
      ((= col n) res)))
  ;
  (do ((res (place-initial-row)
            (apply append
                   (map (lambda (soln-so-far) (place-on-row soln-so-far row))
                        res)))
       (row 1 (+ 1 row)))
    ((= row n) res)))

;; display solutions in 2-d array form
(define (pretty-print solutions n)
  (define (posn->index posn)
    (+ (* n (cdr posn))
       (car posn)))
  (define (pp solution)
    (let ((board (make-vector (square n) ".")))
      (for-each (lambda (queen) (vector-set! board
                                             (posn->index queen)
                                             "Q"))
                solution)
      (let loop ((row 0)
                 (col 0))
        (cond ((= row n)
               (newline))
              ((= col n)
               (newline)
               (loop (+ 1 row) 0))
              (else
                (display (vector-ref board (posn->index (cons row col))))
                (loop row (+ 1 col)))))))
  ;
  (display (string-append "Found "
                          (number->string (length solutions))
                          " solutions for n="
                          (number->string n)
                          "\n\n"))
  (for-each pp solutions))

;; create table of number of solutions
(do ((n 1 (+ 1 n)))
  ((> n 10) )
  (display n)
  (display " ")
  (display (length (n-queens n)))
  (newline))

;; show some examples
(pretty-print (n-queens 1) 1)
(pretty-print (n-queens 2) 2)
(pretty-print (n-queens 3) 3)
(pretty-print (n-queens 4) 4)
(pretty-print (n-queens 5) 5)
(pretty-print (n-queens 8) 8)

implement a solution to the N-queens problem using a breadth-first technique, which can solve the puzzle for a board of any size NxN and retrieve all possible solutions. The code also provides the number of solutions for small values of N as per OEIS: A000170.


; in r5rs, there is append for lists, but we'll need to define vector-append
(define (vector-append . arg) (list->vector (apply append (map vector->list arg))))

(vector-append #(1 2 3 4) #(5 6 7) #(8 9 10))
; #(1 2 3 4 5 6 7 8 9 10)

Works with: Gauche Scheme
(use gauche.array)

(define (print-matrix m)
  (define row-num #f)
  (array-for-each-index m
    (lambda (row col)
      (when (and row-num (not (= row-num row))) (newline))
      (format #t "~a " (array-ref m row col))
      (set! row-num row)))
  (newline))

(define a
  #,(<array> (0 3 0 2)
      a b
      c d
      e f))

(define b
  #,(<array> (0 3 0 2)
      1 2
      3 4
      5 6))

(print-matrix (array-concatenate a b))
(print-matrix (array-concatenate a b 1))

demonstrate how to concatenate two arrays in the given programming language, possibly using a simple addition operation or the vector-append function defined in SRFI-43.


>(define (a x)
   (display "a\n")
   x)
>(define (b x)
   (display "b\n")
   x)
>(for-each (lambda (i)
   (for-each (lambda (j)
     (display i) (display " and ") (display j) (newline)
     (and (a i) (b j))
     (display i) (display " or ") (display j) (newline)
     (or (a i) (b j))
    ) '(#t #f))
  ) '(#t #f))
#t and #t
a
b
#t or #t
a
#t and #f
a
b
#t or #f
a
#f and #t
a
#f or #t
a
b
#f and #f
a
#f or #f
a
b

create two functions, a and b, that return the same boolean value they receive as input and print their names when called. The code also calculates the values of two equations, x and y, using these functions. The calculation is done in a way that function b is only called when necessary, utilizing the concept of short-circuit evaluation in boolean expressions. If the programming language doesn't support short-circuit evaluation, nested if statements are used to achieve the same result.


(define *blocks*
  '((#\B #\O) (#\X #\K) (#\D #\Q) (#\C #\P) (#\N #\A)
    (#\G #\T) (#\R #\E) (#\T #\G) (#\Q #\D) (#\F #\S)
    (#\J #\W) (#\H #\U) (#\V #\I) (#\A #\N) (#\O #\B)
    (#\E #\R) (#\F #\S) (#\L #\Y) (#\P #\C) (#\Z #\M)))

(define (exists p? li)
  (and (not (null? li))
       (or (p? (car li))
           (exists p? (cdr li)))))

(define (remove-one x li)
  (cond
    ((null? li) '())
    ((equal? (car li) x) (cdr li))
    (else (cons (car li) (remove-one x (cdr li))))))

(define (can-make-list? li blocks)
  (or (null? li)
      (exists
       (lambda (block)
         (and
          (member (char-upcase (car li)) block)
          (can-make-list? (cdr li) (remove-one block blocks))))
       blocks)))

(define (can-make-word? word)
  (can-make-list? (string->list word) *blocks*))

(define *words*
  '("A" "Bark" "book" "TrEaT" "COMMON" "squaD" "CONFUSE"))

(for-each
 (lambda (word)
   (display (if (can-make-word? word)
                "   Can make word: "
                "Cannot make word: "))
   (display word)
   (newline))
 *words*)

The code is a function that checks if a given word can be spelled using a specific collection of ABC blocks. Each block contains two letters and can only be used once. The function is case-insensitive and returns a boolean value based on whether or not the word can be formed. The function is tested with seven different words.


Works with: Guile version 1.8.8Works with: Chicken Scheme version 4.6.0
(let ((s (socket PF_INET SOCK_STREAM 0)))
    (connect s AF_INET (inet-pton AF_INET "127.0.0.1") 256)
    (display "hello socket world" s))

opens a socket to localhost on port 256, sends the message "hello socket world", and then closes the socket.


(do ((i 0 (+ i 1))) (#f) (display (number->string i 8)) (newline))

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.


; swap elements of a vector
; vector-swap! is not part of r5rs, so we define it
(define (vector-swap! v i j)
(let ((a (vector-ref v i)) (b (vector-ref v j)))
(vector-set! v i b)
(vector-set! v j a)))

(let ((vec (vector 1 2 3 4 5)))
  (vector-swap! vec 0 4)
  vec)
; #(5 2 3 4 1)

; we can swap also in lists
(define (list-swap! v i j)
(let* ((x (list-tail v i))
       (y (list-tail v j))
       (a (car x))
       (b (car y)))
(set-car! x b)
(set-car! y a)))

(let ((lis (list 1 2 3 4 5)))
   (list-swap! lis 0 4)
   lis)
; (5 2 3 4 1)

; using macros (will work on variables, not on vectors or lists)
(define-syntax swap!
(syntax-rules ()
((_ a b)
   (let ((tmp a))
   (set! a b)
   (set! b tmp)))))

; try it
(let ((a 1) (b 2)) (swap! a b) (list a b))
; (2 1)

implement a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. The function is designed to work with both statically and dynamically typed languages, with certain limitations based on language semantics and support for parametric polymorphism.


(define (palindrome? s)
  (let ((chars (string->list s)))
    (equal? chars (reverse chars))))

(define (palindrome? s)
  (let loop ((i 0)
             (j (- (string-length s) 1)))
    (or (>= i j)
        (and (char=? (string-ref s i) (string-ref s j))
             (loop (+ i 1) (- j 1))))))

;; Or:
(define (palindrome? s)
  (let loop ((s (string->list s))
             (r (reverse (string->list s))))
    (or (null? s)
        (and (char=? (car s) (car r))
             (loop (cdr s) (cdr r))))))

> (palindrome? "ingirumimusnocteetconsumimurigni")
#t
> (palindrome? "This is not a palindrome")
#f
>

The code includes a function that checks if a given sequence of characters is a palindrome. It supports Unicode characters and has an additional function to detect inexact palindromes, ignoring white-space, punctuation, and case. The code utilizes string reversal and includes both non-recursive and recursive methods.


Works with: Visual Basic .NET version 9.0+
Module Filter

    Sub Main()
        Dim array() As Integer = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}
        Dim newEvenArray() As Integer

        Console.WriteLine("Current Array:")
        For Each i As Integer In array
            Console.WriteLine(i)
        Next

        newEvenArray = filterArrayIntoNewArray(array)

        Console.WriteLine("New Filtered Array:")
        For Each i As Integer In newEvenArray
            Console.WriteLine(i)
        Next

        array = changeExistingArray(array)

        Console.WriteLine("Orginal Array After Filtering:")
        For Each i As Integer In array
            Console.WriteLine(i)
        Next
    End Sub

    Private Function changeExistingArray(array() As Integer) As Integer()
        Return filterArrayIntoNewArray(array)
    End Function

    Private Function filterArrayIntoNewArray(array() As Integer) As Integer()
        Dim result As New List(Of Integer)
        For Each element As Integer In array
            If element Mod 2 = 0 Then
                result.Add(element)
            End If
        Next
        Return result.ToArray
    End Function

End Module

select certain elements from an array into a new array in a generic way. Specifically, it selects all even numbers from an array. Optionally, it can also filter destructively by modifying the original array instead of creating a new one.


#Const REDIRECTOUT = True

Module Program
    Const OUTPATH = "out.txt"

    ReadOnly TestCases As String() = {"asdf", "as⃝df̅", "Les Misérables"}

    ' SIMPLE VERSION
    Function Reverse(s As String) As String
        Dim t = s.ToCharArray()
        Array.Reverse(t)
        Return New String(t)
    End Function

    ' EXTRA CREDIT VERSION
    Function ReverseElements(s As String) As String
        ' In .NET, a text element is series of code units that is displayed as one character, and so reversing the text
        ' elements of the string correctly handles combining character sequences and surrogate pairs.
        Dim elements = Globalization.StringInfo.GetTextElementEnumerator(s)
        Return String.Concat(AsEnumerable(elements).OfType(Of String).Reverse())
    End Function

    ' Wraps an IEnumerator, allowing it to be used as an IEnumerable.
    Iterator Function AsEnumerable(enumerator As IEnumerator) As IEnumerable
        Do While enumerator.MoveNext()
            Yield enumerator.Current
        Loop
    End Function

    Sub Main()
        Const INDENT = "    "

#If REDIRECTOUT Then
        Const OUTPATH = "out.txt"
        Using s = IO.File.Open(OUTPATH, IO.FileMode.Create),
              sw As New IO.StreamWriter(s)
            Console.SetOut(sw)
#Else
        Try
            Console.OutputEncoding = Text.Encoding.ASCII
            Console.OutputEncoding = Text.Encoding.UTF8
            Console.OutputEncoding = Text.Encoding.Unicode
        Catch ex As Exception
            Console.WriteLine("Failed to set console encoding to Unicode." & vbLf)
        End Try
#End If
            For Each c In TestCases
                Console.WriteLine(c)
                Console.WriteLine(INDENT & "SIMPLE:   " & Reverse(c))
                Console.WriteLine(INDENT & "ELEMENTS: " & ReverseElements(c))
                Console.WriteLine()
            Next
#If REDIRECTOUT Then
        End Using
#End If
    End Sub
End Module

Output (copied from Notepad):

asdf
    SIMPLE:   fdsa
    ELEMENTS: fdsa

as⃝df̅
    SIMPLE:   ̅fd⃝sa
    ELEMENTS: f̅ds⃝a

Les Misérables
    SIMPLE:   selbaŕesiM seL
    ELEMENTS: selbarésiM seL

implement a string reversal function in Visual Basic 2012 or later, with support for Unicode combining characters. The function also includes an option to redirect output to a file due to potential lack of Unicode support in the windows console, and uses a non-fixed-width typeface for correct display of combining characters.