Works with: Swift version 3
import Foundation

extension Array {
    mutating func shuffle() {
        guard count > 1 else { return }

        for i in 0..<self.count - 1 {
            let j = Int(arc4random_uniform(UInt32(count - i))) + i
            guard i != j else { continue }
            swap(&self[i], &self[j])
        }
    }
}

enum Direction:Int {
    case north = 1
    case south = 2
    case east = 4
    case west = 8

    static var allDirections:[Direction] {
        return [Direction.north, Direction.south, Direction.east, Direction.west]
    }

    var opposite:Direction {
        switch self {
        case .north:
            return .south
        case .south:
            return .north
        case .east:
            return .west
        case .west:
            return .east
        }
    }

    var diff:(Int, Int) {
        switch self {
        case .north:
            return (0, -1)
        case .south:
            return (0, 1)
        case .east:
            return (1, 0)
        case .west:
            return (-1, 0)
        }
    }

    var char:String {
        switch self {
        case .north:
            return "N"
        case .south:
            return "S"
        case .east:
            return "E"
        case .west:
            return "W"
        }
    }

}

class MazeGenerator {
    let x:Int
    let y:Int
    var maze:[[Int]]

    init(_ x:Int, _ y:Int) {
        self.x  = x
        self.y = y
        let column = [Int](repeating: 0, count: y)
        self.maze = [[Int]](repeating: column, count: x)
        generateMaze(0, 0)
    }

    private func generateMaze(_ cx:Int, _ cy:Int) {
        var directions = Direction.allDirections
        directions.shuffle()
        for direction in directions {
            let (dx, dy) = direction.diff
            let nx = cx + dx
            let ny = cy + dy
            if inBounds(nx, ny) && maze[nx][ny] == 0 {
                maze[cx][cy] |= direction.rawValue
                maze[nx][ny] |= direction.opposite.rawValue
                generateMaze(nx, ny)
            }
        }
    }

    private func inBounds(_ testX:Int, _ testY:Int) -> Bool {
        return inBounds(value:testX, upper:self.x) && inBounds(value:testY, upper:self.y)
    }

    private func inBounds(value:Int, upper:Int) -> Bool {
        return (value >= 0) && (value < upper)
    }

    func display() {
        let cellWidth = 3
        for j in 0..<y {
            // Draw top edge
            var topEdge = ""
            for i in 0..<x {
                topEdge += "+"
                topEdge += String(repeating: (maze[i][j] & Direction.north.rawValue) == 0 ? "-" : " ", count: cellWidth)
            }
            topEdge += "+"
            print(topEdge)

            // Draw left edge
            var leftEdge = ""
            for i in 0..<x {
                leftEdge += (maze[i][j] & Direction.west.rawValue) == 0 ? "|" : " "
                leftEdge += String(repeating: " ", count: cellWidth)
            }
            leftEdge += "|"
            print(leftEdge)
        }

        // Draw bottom edge
        var bottomEdge = ""
        for _ in 0..<x {
            bottomEdge += "+"
            bottomEdge += String(repeating: "-", count: cellWidth)
        }
        bottomEdge += "+"
        print(bottomEdge)
    }

    func displayInts() {
        for j in 0..<y {
            var line = ""
            for i in 0..<x {
                line += String(maze[i][j]) + "\t"
            }
            print(line)
        }
    }

    func displayDirections() {
        for j in 0..<y {
            var line = ""
            for i in 0..<x {
                line += getDirectionsAsString(maze[i][j]) + "\t"
            }
            print(line)
        }
    }

    private func getDirectionsAsString(_ value:Int) -> String {
        var line = ""
        for direction in Direction.allDirections {
            if (value & direction.rawValue) != 0 {
                line += direction.char
            }
        }
        return line
    }
}

let x = 20
let y = 10
let maze = MazeGenerator(x, y)
maze.display()

generate and display a maze using the Depth-first search algorithm. It starts from a random cell, marks it as visited, and gets a list of its neighbors. For each unvisited neighbor, it removes the wall between the current cell and the neighbor, and then recursively continues the process with the neighbor as the current cell.


Works with: Swift 4.2
//
//  main.swift
//  pi digits
//
//  Created by max goren on 11/11/21.
//  Copyright © 2021 maxcodes. All rights reserved.
//

import Foundation

var r = [Int]()
var i = 0
var k = 2800
var b = 0
var c = 0
var d = 0

for _ in 0...2800 {
    r.append(2000);
}
while k > 0 {
    d = 0;
    i = k;
    while (true) {
        d = d + r[i] * 10000
        b = 2 * i - 1
        r[i] = d % b
        d = d / b
        i = i - 1
        if i == 0 {
            break;
        }
        d = d * i;
    }
    print(c +  d / 10000, "")
    c = d % 10000
    k = k - 14
}

are designed to continuously calculate and output the next decimal digit of Pi, starting from 3.14159265, until the user aborts the operation. The calculation of Pi is not based on any built-in constants or functions.


let a = [1,2,1,3,2]
let b = [1,2,0,4,4,0,0,0]
println(lexicographicalCompare(a, b)) // this is "less than"

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


func ackerman(m:Int, n:Int) -> Int {
    if m == 0 {
        return n+1
    } else if n == 0 {
        return ackerman(m-1, 1)
    } else {
        return ackerman(m-1, ackerman(m, n-1))
    }
}

Implement the Ackermann function which is a recursive function that takes two non-negative arguments and returns a value based on the specified conditions. The function should ideally support arbitrary precision due to its rapid growth.


	let maxn = 31

	func nq(n: Int) -> Int {
	    var cols = Array(repeating: 0, count: maxn)
	    var diagl = Array(repeating: 0, count: maxn)
	    var diagr = Array(repeating: 0, count: maxn)
	    var posibs = Array(repeating: 0, count: maxn)
	    var num = 0
	    for q0 in 0...n-3 {
		for q1 in q0+2...n-1 {
		    let bit0: Int = 1<<q0
		    let bit1: Int = 1<<q1
		    var d: Int = 0
		    cols[0] = bit0 | bit1 | (-1<<n)
		    diagl[0] = (bit0<<1|bit1)<<1
		    diagr[0] = (bit0>>1|bit1)>>1

		    var posib: Int = ~(cols[0] | diagl[0] | diagr[0])

		    while (d >= 0) {
			while(posib != 0) {
			    let bit: Int = posib & -posib
			    let ncols: Int = cols[d] | bit
			    let ndiagl: Int = (diagl[d] | bit) << 1;
			    let ndiagr: Int = (diagr[d] | bit) >> 1;
			    let nposib: Int = ~(ncols | ndiagl | ndiagr);
			    posib^=bit
			    num += (ncols == -1 ? 1 : 0)
			    if (nposib != 0){
				if(posib != 0) {
				    posibs[d] = posib
				    d += 1
				}
				cols[d] = ncols
				diagl[d] = ndiagl
				diagr[d] = ndiagr
				posib = nposib
			    }
			}
			d -= 1
			posib = d<0 ? n : posibs[d]

		    }
		}

	    }
	    return num*2
	}
	if(CommandLine.arguments.count == 2) {

	    let board_size: Int = Int(CommandLine.arguments[1])!
	    print ("Number of solutions for board size \(board_size) is: \(nq(n:board_size))")

	} else {
	    print("Usage: 8q <n>")
	}

solve the N-queens problem, extending the eight queens puzzle to a board of size NxN. It also provides the number of solutions for small values of N (refer OEIS: A000170). This is a port of an optimized C code.


let array1 = [1,2,3]
let array2 = [4,5,6]
let array3 = array1 + array2

demonstrate how to concatenate two arrays.


struct KnapsackItem {
  var name: String
  var weight: Int
  var value: Int
}

func knapsack(items: [KnapsackItem], limit: Int) -> [KnapsackItem] {
  var table = Array(repeating: Array(repeating: 0, count: limit + 1), count: items.count + 1)

  for j in 1..<items.count+1 {
    let item = items[j-1]

    for w in 1..<limit+1 {
      if item.weight > w {
        table[j][w] = table[j-1][w]
      } else {
        table[j][w] = max(table[j-1][w], table[j-1][w-item.weight] + item.value)
      }
    }
  }

  var result = [KnapsackItem]()
  var w = limit

  for j in stride(from: items.count, to: 0, by: -1) where table[j][w] != table[j-1][w] {
    let item = items[j-1]

    result.append(item)

    w -= item.weight
  }

  return result
}

let items = [
  KnapsackItem(name: "map", weight: 9, value: 150), KnapsackItem(name: "compass", weight: 13, value: 35),
  KnapsackItem(name: "water", weight: 153, value: 200), KnapsackItem(name: "sandwich", weight: 50, value: 160),
  KnapsackItem(name: "glucose", weight: 15, value: 60), KnapsackItem(name: "tin", weight: 68, value: 45),
  KnapsackItem(name: "banana", weight: 27, value: 60), KnapsackItem(name: "apple", weight: 39, value: 40),
  KnapsackItem(name: "cheese", weight: 23, value: 30), KnapsackItem(name: "beer", weight: 52, value: 10),
  KnapsackItem(name: "suntan cream", weight: 11, value: 70), KnapsackItem(name: "camera", weight: 32, value: 30),
  KnapsackItem(name: "t-shirt", weight: 24, value: 15), KnapsackItem(name: "trousers", weight: 48, value: 10),
  KnapsackItem(name: "umbrella", weight: 73, value: 40), KnapsackItem(name: "waterproof trousers", weight: 42, value: 70),
  KnapsackItem(name: "waterproof overclothes", weight: 43, value: 75), KnapsackItem(name: "note-case", weight: 22, value: 80),
  KnapsackItem(name: "sunglasses", weight: 7, value: 20), KnapsackItem(name: "towel", weight: 18, value: 12),
  KnapsackItem(name: "socks", weight: 4, value: 50), KnapsackItem(name: "book", weight: 30, value: 10)
]

let kept = knapsack(items: items, limit: 400)

print("Kept: ")

for item in kept {
  print("  \(item.name)")
}

let (tValue, tWeight) = kept.reduce((0, 0), { ($0.0 + $1.value, $0.1 + $1.weight) })

print("For a total value of \(tValue) and a total weight of \(tWeight)")

The code determines the optimal combination of items a tourist can carry in his knapsack, given a maximum weight limit of 4kg (400 dag), such that the total value of the items is maximized. The items cannot be divided or diminished.


class Person {
    let name:String
    var candidateIndex = 0
    var fiance:Person?
    var candidates = [Person]()

    init(name:String) {
        self.name = name
    }

    func rank(p:Person) -> Int {
        for (i, candidate) in enumerate(self.candidates) {
            if candidate === p {
                return i
            }
        }
        return self.candidates.count + 1
    }

    func prefers(p:Person) -> Bool {
        if let fiance = self.fiance {
            return self.rank(p) < self.rank(fiance)
        }
        return false
    }

    func nextCandidate() -> Person? {
        if self.candidateIndex >= self.candidates.count {
            return nil
        }
        return self.candidates[candidateIndex++]
    }

    func engageTo(p:Person) {
        p.fiance?.fiance = nil
        p.fiance = self
        self.fiance?.fiance = nil
        self.fiance = p
    }

    func swapWith(p:Person) {
        let thisFiance = self.fiance
        let pFiance = p.fiance
        println("\(self.name) swapped partners with \(p.name)")
        if pFiance != nil && thisFiance != nil {
            self.engageTo(pFiance!)
            p.engageTo(thisFiance!)
        }
    }
}

func isStable(guys:[Person], gals:[Person]) -> Bool {
    for guy in guys {
        for gal in gals {
            if guy.prefers(gal) && gal.prefers(guy) {
                return false
            }
        }
    }
    return true
}

func engageEveryone(guys:[Person]) {
    var done = false
    while !done {
        done = true
        for guy in guys {
            if guy.fiance == nil {
                done = false
                if let gal = guy.nextCandidate() {
                    if gal.fiance == nil || gal.prefers(guy) {
                        guy.engageTo(gal)
                    }
                }
            }
        }
    }
}

func doMarriage() {
    let abe  = Person(name: "Abe")
    let bob  = Person(name: "Bob")
    let col  = Person(name: "Col")
    let dan  = Person(name: "Dan")
    let ed   = Person(name: "Ed")
    let fred = Person(name: "Fred")
    let gav  = Person(name: "Gav")
    let hal  = Person(name: "Hal")
    let ian  = Person(name: "Ian")
    let jon  = Person(name: "Jon")
    let abi  = Person(name: "Abi")
    let bea  = Person(name: "Bea")
    let cath = Person(name: "Cath")
    let dee  = Person(name: "Dee")
    let eve  = Person(name: "Eve")
    let fay  = Person(name: "Fay")
    let gay  = Person(name: "Gay")
    let hope = Person(name: "Hope")
    let ivy  = Person(name: "Ivy")
    let jan  = Person(name: "Jan")

    abe.candidates  = [abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay]
    bob.candidates  = [cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay]
    col.candidates  = [hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan]
    dan.candidates  = [ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi]
    ed.candidates   = [jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay]
    fred.candidates = [bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay]
    gav.candidates  = [gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay]
    hal.candidates  = [abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee]
    ian.candidates  = [hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve]
    jon.candidates  = [abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope]
    abi.candidates  = [bob, fred, jon, gav, ian, abe, dan, ed, col, hal]
    bea.candidates  = [bob, abe, col, fred, gav, dan, ian, ed, jon, hal]
    cath.candidates = [fred, bob, ed, gav, hal, col, ian, abe, dan, jon]
    dee.candidates  = [fred, jon, col, abe, ian, hal, gav, dan, bob, ed]
    eve.candidates  = [jon, hal, fred, dan, abe, gav, col, ed, ian, bob]
    fay.candidates  = [bob, abe, ed, ian, jon, dan, fred, gav, col, hal]
    gay.candidates  = [jon, gav, hal, fred, bob, abe, col, ed, dan, ian]
    hope.candidates = [gav, jon, bob, abe, ian, dan, hal, ed, col, fred]
    ivy.candidates  = [ian, col, hal, gav, fred, bob, abe, ed, jon, dan]
    jan.candidates  = [ed, hal, gav, abe, bob, jon, col, ian, fred, dan]

    let guys = [abe, bob, col, dan, ed, fred, gav, hal, ian, jon]
    let gals = [abi, bea, cath, dee, eve, fay, gay, hope, ivy, jan]

    engageEveryone(guys)

    for guy in guys {
        println("\(guy.name) is engaged to \(guy.fiance!.name)")
    }

    println("Stable = \(isStable(guys, gals))")
    jon.swapWith(fred)
    println("Stable = \(isStable(guys, gals))")

}

doMarriage()

"Implement the Gale-Shapley algorithm to solve the Stable Marriage problem. The program takes as input the preferences of ten men and ten women, and outputs a stable set of engagements. It then perturbs this set to form an unstable set of engagements and checks this new set for stability."


func a(v: Bool) -> Bool {
  print("a")
  return v
}

func b(v: Bool) -> Bool {
  print("b")
  return v
}

func test(i: Bool, j: Bool) {
  println("Testing a(\(i)) && b(\(j))")
  print("Trace:  ")
  println("\nResult: \(a(i) && b(j))")

  println("Testing a(\(i)) || b(\(j))")
  print("Trace:  ")
  println("\nResult: \(a(i) || b(j))")

  println()
}

test(false, false)
test(false, true)
test(true, false)
test(true, true)

The code defines two functions, a and b, which return and print the same boolean value. The code then calculates and assigns the values of two equations, x = a(i) and b(j), and y = a(i) or b(j), using short-circuit evaluation to ensure function b is only called when necessary. If the programming language doesn't support short-circuit evaluation, nested if statements are used to achieve the same result.


import Foundation

func Blockable(str: String) -> Bool {

    var blocks = [
        "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
        "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" ]

    var strUp = str.uppercaseString
    var final = ""

    for char: Character in strUp {
        var CharString: String = ""; CharString.append(char)
        for j in 0..<blocks.count {
            if blocks[j].hasPrefix(CharString) ||
               blocks[j].hasSuffix(CharString) {
                final.append(char)
                blocks[j] = ""
                break
            }
        }
    }

    return final == strUp
}

func CanOrNot(can: Bool) -> String {
    return can ? "can" : "cannot"
}

for str in [ "A", "BARK", "BooK", "TrEaT", "comMON", "sQuAd", "Confuse" ] {
    println("'\(str)' \(CanOrNot(Blockable(str))) be spelled with blocks.")
}

"Output: The code defines 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."


import Foundation

public struct OID {
  public var val: String

  public init(_ val: String) {
    self.val = val
  }
}

extension OID: CustomStringConvertible {
  public var description: String {
    return val
  }
}

extension OID: Comparable {
  public static func < (lhs: OID, rhs: OID) -> Bool {
    let split1 = lhs.val.components(separatedBy: ".").compactMap(Int.init)
    let split2 = rhs.val.components(separatedBy: ".").compactMap(Int.init)
    let minSize = min(split1.count, split2.count)

    for i in 0..<minSize {
      if split1[i] < split2[i] {
        return true
      } else if split1[i] > split2[i] {
        return false
      }
    }

    return split1.count < split2.count
  }

  public static func == (lhs: OID, rhs: OID) -> Bool {
    return lhs.val == rhs.val
  }
}

let ids = [
  "1.3.6.1.4.1.11.2.17.19.3.4.0.10",
  "1.3.6.1.4.1.11.2.17.5.2.0.79",
  "1.3.6.1.4.1.11.2.17.19.3.4.0.4",
  "1.3.6.1.4.1.11150.3.4.0.1",
  "1.3.6.1.4.1.11.2.17.19.3.4.0.1",
  "1.3.6.1.4.1.11150.3.4.0"
].map(OID.init)

for id in ids.sorted() {
  print(id)
}

sort a list of Object Identifiers (OIDs) in their natural lexicographical order. The OIDs are strings of non-negative integers separated by dots.


import Foundation

func octalSuccessor(value: String) -> String {
   if value.isEmpty {
        return "1"
   } else {
     let i = value.startIndex, j = value.endIndex.predecessor()
     switch (value[j]) {
       case "0": return value[i..<j] + "1"
       case "1": return value[i..<j] + "2"
       case "2": return value[i..<j] + "3"
       case "3": return value[i..<j] + "4"
       case "4": return value[i..<j] + "5"
       case "5": return value[i..<j] + "6"
       case "6": return value[i..<j] + "7"
       case "7": return octalSuccessor(value[i..<j]) + "0"
       default:
         NSException(name:"InvalidDigit", reason: "InvalidOctalDigit", userInfo: nil).raise();
         return ""
     }
  }
}

var n = "0"
while strtoul(n, nil, 8) < UInt.max {
  println(n)
  n = octalSuccessor(n)
}

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


func swap<T>(inout a: T, inout b: T) {
  (a, b) = (b, a)
}

implement a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. The function should be able to handle both statically and dynamically typed languages, and account for potential restrictions in type compatibility and language support for parametric polymorphism. It is noted that destructive operations like swapping may not be allowed in some functional languages. The Swift standard library's existing swap function is also acknowledged.


Works with: Swift version 1.2
import Foundation

// Allow for easy character checking
extension String {
    subscript (i: Int) -> String {
        return String(Array(self)[i])
    }
}

func isPalindrome(str:String) -> Bool {
    if (count(str) == 0 || count(str) == 1) {
        return true
    }
    let removeRange = Range<String.Index>(start: advance(str.startIndex, 1), end: advance(str.endIndex, -1))
    if (str[0] == str[count(str) - 1]) {
        return isPalindrome(str.substringWithRange(removeRange))
    }
    return false
}
Works with: Swift version 2.0
func isPal(str: String) -> Bool {
  let c = str.characters
  return lazy(c).reverse()
    .startsWith(c[c.startIndex...advance(c.startIndex, c.count / 2)])
}

implement a function to check if a given sequence of characters is a palindrome. It also supports Unicode characters. Additionally, it includes a second function to detect inexact palindromes, ignoring white-space, punctuation, and case-sensitivity. It may also be useful for testing a function.


print("USER: \(ProcessInfo.processInfo.environment["USER"] ?? "Not set")")
print("PATH: \(ProcessInfo.processInfo.environment["PATH"] ?? "Not set")")

"Demonstrates how to retrieve a process's environment variables such as PATH, HOME, or USER in a Unix system."


//Aamrun, 3rd February 2023

func F(n: Int,x: Int,y: Int) -> Int {
  if (n == 0) {
    return x + y;
  }

  else if (y == 0) {
    return x;
  }

    return F(n: n - 1, x: F(n: n, x: x, y: y - 1), y: F(n: n, x: x, y: y - 1) + y);
}

print("F1(3,3) = " + String(F(n: 1,x: 3,y: 3)));

//Aamrun, 3rd February 2023

func F(n: Int,x: Int,y: Int) -> Int {
  if n == 0 {
    return x + y
  }

  else if y == 0 {
    return x
  }

    return F(n: n - 1, x: F(n: n, x: x, y: y - 1), y: F(n: n, x: x, y: y - 1) + y)
}

print("F1(3,3) = " + String(F(n: 1,x: 3,y: 3)))

implement the Sudan function, a non-primitive recursive function. The function takes two arguments, x and y, and returns their sum if the function is called with zero recursion depth. If the recursion depth is greater than zero and y is zero, it returns x. Otherwise, it recursively calls itself with modified arguments. The implementation is provided in both C-like and pure Swift syntax.


(define (make-stack)
  (let ((st '()))
    (lambda (message . args)
      (case message
        ((empty?) (null? st))
        ((top) (if (null? st)
                   'empty
                   (car st)))
        ((push) (set! st (cons (car args) st)))
        ((pop) (if (null? st)
                   'empty
                   (let ((result (car st)))
                     (set! st (cdr st))
                     result)))
        (else 'badmsg)))))

implement a stack data structure with basic operations such as push (adding an element to the top of the stack), pop (removing the topmost element from the stack and returning it), and empty (checking if the stack is empty). The stack follows a last in, first out (LIFO) access policy.


(define (fib-iter n)
  (do ((num 2 (+ num 1))
       (fib-prev 1 fib)
       (fib 1 (+ fib fib-prev)))
      ((>= num n) fib)))
(define (fib-rec n)
  (if (< n 2)
      n
      (+ (fib-rec (- n 1))
         (fib-rec (- n 2)))))

(define (fib n)
  (let loop ((a 0) (b 1) (n n))
    (if (= n 0) a
        (loop b (+ a b) (- n 1)))))

(define (fib)
  (define (nxt lv nv) (cons nv (lambda () (nxt nv (+ lv nv)))))
  (cons 0 (lambda () (nxt 0 1))))

;;; test...
(define (show-stream-take n strm)
  (define (shw-nxt n strm) (begin (display (car strm))
                                  (if (> n 1) (begin (display " ") (shw-nxt (- n 1) ((cdr strm)))) (display ")"))))
  (begin (display "(") (shw-nxt n strm)))
(show-stream-take 30 (fib))

The code is a function that generates the nth Fibonacci number. It can implement this either iteratively or recursively, though the latter is generally slower. The function also optionally supports negative numbers. The code is efficient and uses a tail recursive version, generating only the final nth Fibonacci number without wasteful repeated calls. It also includes a procedure that generates the Fibonacci sequence using a simplified version of a lazy list/stream, using almost no memory during sequence generation.


(define filter
  (lambda (fn lst)
    (let iter ((lst lst) (result '()))
      (if (null? lst)
         (reverse result)
         (let ((item (car lst))
               (rest (cdr lst)))
           (if (fn item)
               (iter rest (cons item result))
               (iter rest result)))))))

> (filter even? '(1 2 3 4 5 6 7 8 9 10))
(2 4 6 8 10)

(define (select-even lst)
  (filter even? lst))

(select-even '(1 2 3 4 5 6 7 8 9 10))

"Implements a generic filter function to select certain elements from an array into a new array, demonstrated by selecting all even numbers. Additionally, provides a destructive filter solution that modifies the original array instead of creating a new one."


Works with: Guile
(define s "Hello, world!")
(define n 5)
(define m (+ n 6))

(display (substring s n m))
(newline)

(display (substring s n))
(newline)

(display (substring s 0 (- (string-length s) 1)))
(newline)

(display (substring s (string-index s #\o) m))
(newline)

(display (substring s (string-contains s "lo") m))
(newline)

- Extracts a substring starting from the nth character of a specific length m.
- Extracts a substring starting from the nth character up to the end of the string.
- Returns the entire string excluding the last character.
- Extracts a substring starting from a known character within the string of length m.
- Extracts a substring starting from a known substring within the string of length m.
- Supports any valid Unicode code point, including those in the Basic Multilingual Plane or above it.
- References logical characters (code points), not 8-bit code units for UTF-8 or 16-bit code units for UTF-16.
- Does not necessarily support all Unicode characters for other encodings like 8-bit ASCII, or EUC-JP.


(define (string-reverse s)
  (list->string (reverse (string->list s))))
> (string-reverse "asdf")
"fdsa"

Reverses a given string while preserving Unicode combining characters. For instance, it transforms "asdf" to "fdsa" and "as⃝df̅" to "f̅ds⃝a".


Works with: CHICKEN version 5.3.0
Library: r7rs

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

(define-library (avl-trees)

  ;;
  ;; This library implements ‘persistent’ (that is, ‘immutable’) AVL
  ;; trees for R7RS Scheme.
  ;;
  ;; Included are generators of the key-data pairs in a tree. Because
  ;; the trees are persistent (‘immutable’), these generators are safe
  ;; from alterations of the tree.
  ;;
  ;; 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.
  ;;
  ;; Note that the references do not discuss persistent
  ;; implementations. It seems worthwhile to compare the methods of
  ;; implementation.
  ;;

  (export avl)
  (export alist->avl)
  (export avl->alist)
  (export avl?)
  (export avl-empty?)
  (export avl-size)
  (export avl-insert)
  (export avl-delete)
  (export avl-delete-values)
  (export avl-has-key?)
  (export avl-search)
  (export avl-search-values)
  (export avl-make-generator)
  (export avl-pretty-print)
  (export avl-check-avl-condition)
  (export avl-check-usage)

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

  (cond-expand
    (chicken
     (import (only (chicken base) define-record-printer))
     (import (only (chicken format) format))) ; For debugging.
    (else))

  (begin

    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    ;;
    ;; Tools for making generators. These use call/cc and so might be
    ;; inefficient in your Scheme. I am using CHICKEN, in which
    ;; call/cc is not so inefficient.
    ;;
    ;; Often I have made &fail a unique object rather than #f, but in
    ;; this case #f will suffice.
    ;;

    (define &fail #f)

    (define *suspend*
      (make-parameter (lambda (x) x)))

    (define (suspend v)
      ((*suspend*) v))

    (define (fail-forever)
      (let loop ()
        (suspend &fail)
        (loop)))

    (define (make-generator-procedure thunk)
      ;; Make a suspendable procedure that takes no arguments. The
      ;; result is a simple generator of values. (This can be
      ;; elaborated upon for generators to take values on resumption,
      ;; in the manner of Icon co-expressions.)
      (define (next-run return)
        (define (my-suspend v)
          (set! return (call/cc (lambda (resumption-point)
                                  (set! next-run resumption-point)
                                  (return v)))))
        (parameterize ((*suspend* my-suspend))
          (suspend (thunk))
          (fail-forever)))
      (lambda () (call/cc next-run)))

    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    (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))

    (cond-expand
      (chicken (define-record-printer (<avl> rt out)
                 (display "#<avl " out)
                 (display (%key rt) out)
                 (display " " out)
                 (display (%data rt) out)
                 (display " " out)
                 (display (%bal rt) out)
                 (display " " out)
                 (display (%left rt) out)
                 (display " " out)
                 (display (%right rt) out)
                 (display ">" out)))
      (else))

    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    (define avl
      (case-lambda
        (() (%avl #f #f #f #f #f))
        ((pred<? . args) (alist->avl pred<? args))))

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

    (define (avl-size tree)
      (define (traverse p sz)
        (if (not p)
            sz
            (traverse (%left p) (traverse (%right p) (+ sz 1)))))
      (if (avl-empty? tree)
          0
          (traverse tree 0)))

    (define (avl-has-key? pred<? tree key)
      (define (search p)
        (and p
             (let ((k (%key p)))
               (cond ((pred<? key k) (search (%left p)))
                     ((pred<? k key) (search (%right p)))
                     (else #t)))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-has-key? expects a procedure as first argument")
      (and (not (avl-empty? tree))
           (search tree)))

    (define (avl-search pred<? tree key)
      ;; Return the data matching a key, or #f if the key is not
      ;; found. (Note that the data matching the key might be #f.)
      (define (search p)
        (and p
             (let ((k (%key p)))
               (cond ((pred<? key k) (search (%left p)))
                     ((pred<? k key) (search (%right p)))
                     (else (%data p))))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-search expects a procedure as first argument")
      (and (not (avl-empty? tree))
           (search 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 (alist->avl pred<? alst)
      ;; Go from association list to AVL tree.
      (avl-check-usage
       (procedure? pred<?)
       "alist->avl expects a procedure as first argument")
      (let loop ((tree (avl))
                 (lst alst))
        (if (null? lst)
            tree
            (let ((head (car lst)))
              (loop (avl-insert pred<? tree (car head) (cdr head))
                    (cdr lst))))))

    (define (avl->alist tree)
      ;; Go from AVL tree to association list. The output will be in
      ;; order.
      (define (traverse p lst)
        ;; Reverse in-order traversal of the tree, to produce an
        ;; in-order cons-list.
        (if (not p)
            lst
            (traverse (%left p) (cons (cons (%key p) (%data p))
                                      (traverse (%right p) lst)))))
      (if (avl-empty? tree)
          '()
          (traverse 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 (avl-delete pred<? tree key)
      ;; If one is not interested in whether the key was in the tree,
      ;; then throw away that information.
      (let-values (((tree had-key?)
                    (avl-delete-values pred<? tree key)))
        tree))

    (define (balance-for-shrunken-left p)
      ;; Returns two values: a new p and a new fix-balance?
      (case (%bal p)
        ((-1) (values (%avl (%key p) (%data p) 0
                            (%left p) (%right p))
                      #t))
        ((0) (values (%avl (%key p) (%data p) 1
                           (%left p) (%right p))
                     #f))
        ((1)
         ;; Rebalance.
         (let* ((p1 (%right p))
                (bal1 (%bal p1)))
           (case bal1
             ((0)
              ;; A single RR rotation.
              (let* ((p^ (%avl (%key p) (%data p) 1
                               (%left p) (%left p1)))
                     (p1^ (%avl (%key p1) (%data p1) -1
                                p^ (%right p1))))
                (values p1^ #f)))
             ((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^ #t)))
             ((-1)
              ;; 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^ #t)))
             (else (internal-error)))))
        (else (internal-error))))

    (define (balance-for-shrunken-right p)
      ;; Returns two values: a new p and a new fix-balance?
      (case (%bal p)
        ((1) (values (%avl (%key p) (%data p) 0
                           (%left p) (%right p))
                     #t))
        ((0) (values (%avl (%key p) (%data p) -1
                           (%left p) (%right p))
                     #f))
        ((-1)
         ;; Rebalance.
         (let* ((p1 (%left p))
                (bal1 (%bal p1)))
           (case bal1
             ((0)
              ;; A single LL rotation.
              (let* ((p^ (%avl (%key p) (%data p) -1
                               (%right p1) (%right p)))
                     (p1^ (%avl (%key p1) (%data p1) 1
                                (%left p1) p^)))
                (values p1^ #f)))
             ((-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^ #t)))
             ((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^ #t)))
             (else (internal-error)))))
        (else (internal-error))))

    (define (avl-delete-values pred<? tree key)

      (define-syntax balance-L
        (syntax-rules ()
          ((_ p fix-balance?)
           (if fix-balance?
               (balance-for-shrunken-left p)
               (values p #f)))))

      (define-syntax balance-R
        (syntax-rules ()
          ((_ p fix-balance?)
           (if fix-balance?
               (balance-for-shrunken-right p)
               (values p #f)))))

      (define (del r fix-balance?)
        ;; Returns a new r, a new fix-balance?, and key and data to be
        ;; ‘moved up the tree’.
        (if (%right r)
            (let*-values
                (((q fix-balance? key^ data^)
                  (del (%right r) fix-balance?))
                 ((r fix-balance?)
                  (balance-R (%avl (%key r) (%data r) (%bal r)
                                   (%left r) q)
                             fix-balance?)))
              (values r fix-balance? key^ data^))
            (values (%left r) #t (%key r) (%data r))))

      (define (search p fix-balance?)
        ;; Return three values: a new p, a new fix-balance, and
        ;; whether the key was found.
        (cond
         ((not p) (values #f #f #f))
         ((pred<? key (%key p))
          ;; Recursive search down the left branch.
          (let*-values
              (((q fix-balance? found?)
                (search (%left p) fix-balance?))
               ((p fix-balance?)
                (balance-L (%avl (%key p) (%data p) (%bal p)
                                 q (%right p))
                           fix-balance?)))
            (values p fix-balance? found?)))
         ((pred<? (%key p) key)
          ;; Recursive search down the right branch.
          (let*-values
              (((q fix-balance? found?)
                (search (%right p) fix-balance?))
               ((p fix-balance?)
                (balance-R (%avl (%key p) (%data p) (%bal p)
                                 (%left p) q)
                           fix-balance?)))
            (values p fix-balance? found?)))
         ((not (%right p))
          ;; Delete p, replace it with its left branch, then
          ;; rebalance.
          (values (%left p) #t #t))
         ((not (%left p))
          ;; Delete p, replace it with its right branch, then
          ;; rebalance.
          (values (%right p) #t #t))
         (else
          ;; Delete p, but it has both left and right branches,
          ;; and therefore may have complicated branch structure.
          (let*-values
              (((q fix-balance? key^ data^)
                (del (%left p) fix-balance?))
               ((p fix-balance?)
                (balance-L (%avl key^ data^ (%bal p) q (%right p))
                           fix-balance?)))
            (values p fix-balance? #t)))))

      (avl-check-usage
       (procedure? pred<?)
       "avl-delete-values expects a procedure as first argument")
      (if (avl-empty? tree)
          (values tree #f)
          (let-values (((tree fix-balance? found?)
                        (search tree #f)))
            (if found?
                (values (or tree (avl)) #t)
                (values tree #f)))))

    (define avl-make-generator
      (case-lambda
        ((tree) (avl-make-generator tree 1))
        ((tree direction)
         (if (negative? direction)
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%right p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%left p)))
                  &fail)
                (traverse tree)))
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%left p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%right p)))
                  &fail)
                (traverse tree)))))))

    (define avl-pretty-print
      (case-lambda
        ((tree)
         (avl-pretty-print tree (current-output-port)))
        ((tree port)
         (avl-pretty-print tree port
                           (lambda (port key data)
                             (display "(" port)
                             (write key port)
                             (display ", " port)
                             (write data port)
                             (display ")" port))))
        ((tree port key-data-printer)
         ;; In-order traversal, so the printing is done in
         ;; order. Reflect the display diagonally to get the more
         ;; usual orientation of left-to-right, top-to-bottom.
         (define (pad depth)
           (unless (zero? depth)
             (display "  " port)
             (pad (- depth 1))))
         (define (traverse p depth)
           (when p
             (traverse (%left p) (+ depth 1))
             (pad depth)
             (key-data-printer port (%key p) (%data p))
             (display "\t\tdepth = " port)
             (display depth port)
             (display " bal = " port)
             (display (%bal p) port)
             (display "\n" port)
             (traverse (%right p) (+ depth 1))))
         (unless (avl-empty? tree)
           (traverse (%left tree) 1)
           (key-data-printer port (%key tree) (%data tree))
           (display "\t\tdepth = 0  bal = " port)
           (display (%bal tree) port)
           (display "\n" port)
           (traverse (%right tree) 1)))))

    (define (avl-check-avl-condition tree)
      ;; Check that the AVL condition is satisfied.
      (define (check-heights height-L height-R)
        (when (<= 2 (abs (- height-L height-R)))
          (display "*** AVL condition violated ***"
                   (current-error-port))
          (internal-error)))
      (define (get-heights p)
        (if (not p)
            (values 0 0)
            (let-values (((height-LL height-LR)
                          (get-heights (%left p)))
                         ((height-RL height-RR)
                          (get-heights (%right p))))
              (check-heights height-LL height-LR)
              (check-heights height-RL height-RR)
              (values (+ height-LL height-LR)
                      (+ height-RL height-RR)))))
      (unless (avl-empty? tree)
        (let-values (((height-L height-R) (get-heights tree)))
          (check-heights height-L height-R))))

    (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)

(cond-expand
  (DEMONSTRATION
   (begin
     (import (avl-trees))
     (import (scheme base))
     (import (scheme time))
     (import (scheme process-context))
     (import (scheme write))

     (cond-expand
       (chicken
        (import (only (chicken format) format))) ; For debugging.
       (else))

     (define 2**64 (expt 2 64))

     (define seed (truncate-remainder (exact (current-second)) 2**64))
     (define random
       ;; A really slow (but presumably highly portable)
       ;; implementation of Donald Knuth’s linear congruential random
       ;; number generator, returning a rational number in [0,1). See
       ;; https://en.wikipedia.org/w/index.php?title=Linear_congruential_generator&oldid=1076681286
       (let ((a 6364136223846793005)
             (c 1442695040888963407))
         (lambda ()
           (let ((result (/ seed 2**64)))
             (set! seed (truncate-remainder (+ (* a seed) c) 2**64))
             result))))
     (do ((i 0 (+ i 1)))
         ((= i 10))
       (random))

     (define (fisher-yates-shuffle keys)
       (let ((n (vector-length keys)))
         (do ((i 1 (+ i 1)))
             ((= i n))
           (let* ((randnum (random))
                  (j (+ i (floor (* randnum (- n i)))))
                  (xi (vector-ref keys i))
                  (xj (vector-ref keys j)))
             (vector-set! keys i xj)
             (vector-set! keys j xi)))))

     (define (display-key-data key data)
       (display "(")
       (write key)
       (display ", ")
       (write data)
       (display ")"))

     (define (display-tree-contents tree)
       (do ((p (avl->alist tree) (cdr p)))
           ((null? p))
         (display-key-data (caar p) (cdar p))
         (newline)))

     (define (error-stop)
       (display "*** ERROR STOP ***\n" (current-error-port))
       (emergency-exit 1))

     (define n 20)
     (define keys (make-vector (+ n 1)))
     (do ((i 0 (+ i 1)))
         ((= i n))
       ;; To keep things more like Fortran, do not use index zero.
       (vector-set! keys (+ i 1) (+ i 1)))

     (fisher-yates-shuffle keys)

     ;; Insert key-data pairs in the shuffled order.
     (define tree (avl))
     (avl-check-avl-condition tree)
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-insert < tree ix (inexact ix)))
         (avl-check-avl-condition tree)
         (do ((j 1 (+ j 1)))
             ((= j (+ n 1)))
           (let*-values (((k) (vector-ref keys j))
                         ((has-key?) (avl-has-key? < tree k))
                         ((data) (avl-search < tree k))
                         ((data^ has-key?^)
                          (avl-search-values < tree k)))
             (unless (exact? k) (error-stop))
             (if (<= j i)
                 (unless (and has-key? data data^ has-key?^
                              (inexact? data) (= data k)
                              (inexact? data^) (= data^ k))
                   (error-stop))
                 (when (or has-key? data data^ has-key?^)
                   (error-stop)))))))

     (display "----------------------------------------------------------------------\n")
     (display "keys = ")
     (write (cdr (vector->list keys)))
     (newline)
     (display "----------------------------------------------------------------------\n")
     (avl-pretty-print tree)
     (display "----------------------------------------------------------------------\n")
     (display "tree size = ")
     (display (avl-size tree))
     (newline)
     (display-tree-contents tree)
     (display "----------------------------------------------------------------------\n")

     ;;
     ;; Reshuffle the keys, and change the data from inexact numbers
     ;; to strings.
     ;;

     (fisher-yates-shuffle keys)

     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-insert < tree ix (number->string ix)))
         (avl-check-avl-condition tree)))

     (avl-pretty-print tree)
     (display "----------------------------------------------------------------------\n")
     (display "tree size = ")
     (display (avl-size tree))
     (newline)
     (display-tree-contents tree)
     (display "----------------------------------------------------------------------\n")

     ;;
     ;; Reshuffle the keys, and delete the contents of the tree, but
     ;; also keep the original tree by saving it in a variable. Check
     ;; persistence of the tree.
     ;;

     (fisher-yates-shuffle keys)

     (define saved-tree tree)

     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-delete < tree ix))
         (avl-check-avl-condition tree)
         (unless (= (avl-size tree) (- n i)) (error-stop))
         ;; Try deleting a second time.
         (set! tree (avl-delete < tree ix))
         (avl-check-avl-condition tree)
         (unless (= (avl-size tree) (- n i)) (error-stop))
         (do ((j 1 (+ j 1)))
             ((= j (+ n 1)))
           (let ((jx (vector-ref keys j)))
             (unless (eq? (avl-has-key? < tree jx) (< i j))
               (error-stop))
             (let ((data (avl-search < tree jx)))
               (unless (eq? (not (not data)) (< i j))
                 (error-stop))
               (unless (or (not data)
                           (= (string->number data) jx))
                 (error-stop)))
             (let-values (((data found?)
                           (avl-search-values < tree jx)))
               (unless (eq? found? (< i j)) (error-stop))
               (unless (or (and (not data) (<= j i))
                           (and data (= (string->number data) jx)))
                 (error-stop)))))))
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       ;; Is save-tree the persistent value of the tree we just
       ;; deleted?
       (let ((ix (vector-ref keys i)))
         (unless (equal? (avl-search < saved-tree ix)
                         (number->string ix))
           (error-stop))))

     (display "forwards generator:\n")
     (let ((gen (avl-make-generator saved-tree)))
       (do ((pair (gen) (gen)))
           ((not pair))
         (display-key-data (car pair) (cdr pair))
         (newline)))

     (display "----------------------------------------------------------------------\n")

     (display "backwards generator:\n")
     (let ((gen (avl-make-generator saved-tree -1)))
       (do ((pair (gen) (gen)))
           ((not pair))
         (display-key-data (car pair) (cdr pair))
         (newline)))

     (display "----------------------------------------------------------------------\n")

     ))
  (else))

implement an AVL tree with basic operations. The AVL tree is a self-balancing binary search tree where the heights of the two child subtrees of any node differ by at most one. The tree is rebalanced after insertions and deletions to maintain this property. The operations of lookup, insertion, and deletion all take O(log n) time. The tree does not allow duplicate node keys. The code also includes a comparison function for matching keys. The demonstration of the AVL tree is randomized and the tree is pretty printed in a unique way.


(import (scheme base)
        (scheme inexact)
        (scheme write))

;; c1 and c2 are pairs (x y), r a positive radius
(define (find-circles c1 c2 r)
  (define x-coord car) ; for easier to read coordinate extraction from list
  (define y-coord cadr)
  (define (approx= a b) (< (- a b) 0.000001)) ; equal within tolerance
  (define (avg a b) (/ (+ a b) 2))
  (define (distance pt1 pt2)
    (sqrt (+ (square (- (x-coord pt1) (x-coord pt2)))
             (square (- (y-coord pt1) (y-coord pt2))))))
  (define (equal-points? pt1 pt2)
    (and (approx= (x-coord pt1) (x-coord pt2))
         (approx= (y-coord pt1) (y-coord pt2))))
  (define (delete-duplicate pts) ; assume no more than two points in list
    (if (and (= 2 (length pts))
             (equal-points? (car pts) (cadr pts)))
      (list (car pts)) ; keep the first only
      pts))
  ;
  (let ((d (distance c1 c2)))
    (cond ((equal-points? c1 c2) ; coincident points
           (if (> r 0)
             'infinite   ; r > 0
             (list c1))) ; else r = 0
          ((< (* 2 r) d)
           '()) ; circle cannot reach both points, as too far apart
          ((approx= r 0.0) ; r = 0, no circles, as points differ
           '())
          (else ; find up to two circles meeting c1 and c2
            (let* ((mid-pt (list (avg (x-coord c1) (x-coord c2))
                                 (avg (y-coord c1) (y-coord c2))))
                   (offset (sqrt (- (square r)
                                    (square (* 0.5 d)))))
                   (delta-cx (/ (- (x-coord c1) (x-coord c2)) d))
                   (delta-cy (/ (- (y-coord c1) (y-coord c2)) d)))
              (delete-duplicate
                (list (list (- (x-coord mid-pt) (* offset delta-cx))
                            (+ (y-coord mid-pt) (* offset delta-cy)))
                      (list (+ (x-coord mid-pt) (* offset delta-cx))
                            (- (y-coord mid-pt) (* offset delta-cy))))))))))

;; work through the input examples, outputting results
(for-each
  (lambda (c1 c2 r)
    (let ((result (find-circles c1 c2 r)))
      (display "p1: ") (display c1)
      (display " p2: ") (display c2)
      (display " r: ") (display (number->string r))
      (display " => ")
      (cond ((eq? result 'infinite)
             (display "Infinite number of circles"))
            ((null? result)
             (display "No circles"))
            (else
              (display result)))
      (newline)))
  '((0.1234 0.9876) (0.0000 2.0000) (0.1234 0.9876) (0.1234 0.9876) (0.1234 0.9876))
  '((0.8765 0.2345) (0.0000 0.0000) (0.1234 0.9876) (0.8765 0.2345) (0.1234 0.9876))
  '(2.0 1.0 2.0 0.5 0.0))

"Function to calculate two possible circles given two points and a radius in 2D space. The function handles special cases such as when radius is zero, points are coincident, points form a diameter, or points are too distant. The function returns the circles or a special indication when two equal or distinct circles cannot be returned."


(let loop ((first (random 20)))
  (print first)
  (if (not (= first 10))
      (begin
        (print (random 20))
        (loop (random 20)))))

(call/cc
 (lambda (break)
   (let loop ((first (random 20)))
     (print first)
     (if (= first 10)
         (break))
     (print (random 20))
     (loop (random 20)))))

generates and prints random numbers from 0 to 19. If the generated number is 10, the loop stops. If not, a second random number is generated and printed before the loop restarts. If 10 is never generated, the loop runs indefinitely.


#lang scheme

;;; this needs to be changed for other R6RS implementations
(require rnrs/arithmetic/bitwise-6)

;;; modpow, as per the task description.
(define (modpow exponent base)
  (let loop ([square 1] [index (- (bitwise-length exponent) 1)])
    (if (< index 0)
        square
        (loop (modulo (* (if (bitwise-bit-set? exponent index) 2 1)
                      square square) base)
              (- index 1)))))

;;; search through all integers from 1 on to find the first divisor
;;; returns #f if 2^p-1 is prime
(define (mersenne-factor p)
  (for/first ((i (in-range 1 (floor (expt 2 (quotient p 2))) (* 2 p)))
              #:when (and (or (= 1 (modulo i 8)) (= 7 (modulo i 8)))
                          (= 1 (modpow p i))))
    i))

The code implements an algorithm to find a factor of a Mersenne number (in this case, 2^929-1). It uses the properties of Mersenne numbers and the modPow operation to efficiently determine if a number divides the Mersenne number. The algorithm stops when 2kP+1 > sqrt(N). It only works on Mersenne numbers where P is prime.


(define (element? a lst)
  (and (not (null? lst))
       (or (eq? a (car lst))
	   (element? a (cdr lst)))))

; util, not strictly needed
(define (uniq lst)
  (if (null? lst) lst
    (let ((a (car lst)) (b (cdr lst)))
      (if (element? a b)
	(uniq b)
	(cons a (uniq b))))))

(define (intersection a b)
  (cond ((null? a) '())
	((null? b) '())
	(else
	  (append (intersection (cdr a) b)
		  (if (element? (car a) b)
		    (list (car a))
		    '())))))

(define (union a b)
  (if (null? a) b
    (union (cdr a)
	   (if (element? (car a) b)
	     b
	     (cons (car a) b)))))

(define (diff a b) ; a - b
  (if (null? a) '()
    (if (element? (car a) b)
      (diff (cdr a) b)
      (cons (car a) (diff (cdr a) b)))))

(define (subset? a b) ; A ⊆ B
  (if (null? a) #t
    (and (element? (car a) b)
	 (subset? (cdr a) b))))

(define (set-eq? a b)
  (and (subset? a b)
       (subset? b a)))

implement various set operations including set creation, testing if an element is in a set, union, intersection, difference, subset, and equality of two sets. The code also provides options for additional set operations and modifications to a mutable set. The set is implemented using an associative array, binary search tree, hash table, or an ordered array of binary bits. The code also includes efficiency considerations for large sets.


The code determines the years between 2008 and 2121 where Christmas (25th December) falls on a Sunday, using standard date handling libraries. It also compares the results with other languages to identify any anomalies in date/time representation, such as overflow issues similar to y2k problems.


(define (remove-duplicates l)
  (cond ((null? l)
         '())
        ((member (car l) (cdr l))
         (remove-duplicates (cdr l)))
        (else
         (cons (car l) (remove-duplicates (cdr l))))))

(remove-duplicates '(1 2 1 3 2 4 5))
(1 3 2 4 5)

(define (remove-duplicates l)
  (do ((a '() (if (member (car l) a) a (cons (car l) a)))
       (l l (cdr l)))
    ((null? l) (reverse a))))

(remove-duplicates '(1 2 1 3 2 4 5))
(1 2 3 4 5)

"Implements a function to remove duplicate elements from an array using three possible methods: 1) Utilizing a hash table to automatically discard duplicates with a complexity of O(n) on average, 2) Sorting the elements and removing consecutive duplicates with a complexity of O(n log n), 3) Iterating through the list and discarding any element if it appears again with a complexity of O(n^2). Also, an alternative approach using the 'delete-duplicates' function from srfi-1 is available."


(define (split-by l p k)
  (let loop ((low '())
             (high '())
             (l l))
    (cond ((null? l)
           (k low high))
          ((p (car l))
           (loop low (cons (car l) high) (cdr l)))
          (else
           (loop (cons (car l) low) high (cdr l))))))

(define (quicksort l gt?)
  (if (null? l)
      '()
      (split-by (cdr l)
                (lambda (x) (gt? x (car l)))
                (lambda (low high)
                  (append (quicksort low gt?)
                          (list (car l))
                          (quicksort high gt?))))))

(quicksort '(1 3 5 7 9 8 6 4 2) >)

(define (quicksort l gt?)
  (if (null? l)
      '()
      (append (quicksort (filter (lambda (x) (gt? (car l) x)) (cdr l)) gt?)
              (list (car l))
              (quicksort (filter (lambda (x) (not (gt? (car l) x))) (cdr l)) gt?))))

(quicksort '(1 3 5 7 9 8 6 4 2) >)

Works with: Chibi Scheme
Works with: Gauche Scheme
Works with: CHICKEN Scheme version 5.3.0
For CHICKEN:Library: r7rs

;;;-------------------------------------------------------------------
;;;
;;; Quicksort in R7RS Scheme, working in-place on vectors (that is,
;;; arrays). I closely follow the "better quicksort algorithm"
;;; pseudocode, and thus the code is more "procedural" than
;;; "functional".
;;;
;;; I use a random pivot. If you can generate a random number quickly,
;;; this is a good method, but for this demonstration I have taken a
;;; fast linear congruential generator and made it brutally slow. It's
;;; just a demonstration. :)
;;;

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

;;;-------------------------------------------------------------------
;;;
;;; Add "while" loops to the language.
;;;

(define-syntax while
  (syntax-rules ()
    ((_ pred? body ...)
     (let loop ()
       (when pred?
         (begin body ...)
         (loop))))))

;;;-------------------------------------------------------------------
;;;
;;; In-place quicksort.
;;;

(define vector-quicksort!
  (case-lambda

    ;; Use a default pivot selector.
    ((<? vec)
     ;; Random pivot.
     (vector-quicksort! (lambda (vec i-first i-last)
                          (vector-ref vec (randint i-first i-last)))
                        <? vec))

    ;; Specify a pivot selector.
    ((pivot-select <? vec)
     ;;
     ;; The recursion:
     ;;
     (let quicksort! ((i-first 0)
                      (i-last (- (vector-length vec) 1)))
       (let ((n (- i-last i-first -1)))
         (when (> n 1)
           (let* ((pivot (pivot-select vec i-first i-last)))
             (let ((left i-first)
                   (right i-last))
               (while (<= left right)
                 (while (< (vector-ref vec left) pivot)
                   (set! left (+ left 1)))
                 (while (> (vector-ref vec right) pivot)
                   (set! right (- right 1)))
                 (when (<= left right)
                   (let ((lft (vector-ref vec left))
                         (rgt (vector-ref vec right)))
                     (vector-set! vec left rgt)
                     (vector-set! vec right lft)
                     (set! left (+ left 1))
                     (set! right (- right 1)))))
               (quicksort! i-first right)
               (quicksort! left i-last)))))))))

;;;-------------------------------------------------------------------
;;;
;;; A simple linear congruential generator, attributed by
;;; https://en.wikipedia.org/w/index.php?title=Linear_congruential_generator&oldid=1083800601
;;; to glibc and GCC. No attempt has been made to optimize this code.
;;;

(define seed 1)
(define two**31 (expt 2 31))
(define (random-integer)
  (let* ((s0 seed)
         (s1 (truncate-remainder (+ (* 1103515245 s0) 12345)
                                 two**31)))
    (set! seed s1)
    s0))
(define randint
  (case-lambda
    ((n) (truncate-remainder (random-integer) n))
    ((i-first i-last) (+ i-first (randint (- i-last i-first -1))))))

;;;-------------------------------------------------------------------
;;;
;;; A demonstration of in-place vector quicksort.
;;;

(define vec1 (vector-copy #(60 53 100 72 19 67 14
                               31 4 1 5 9 2 6 5 3 5 8
                               28 9 95 22 67 55 20 41
                               42 29 20 74 39)))
(vector-quicksort! < vec1)
(write vec1)
(newline)

;;;-------------------------------------------------------------------

implement the Quicksort algorithm. The algorithm sorts an array or list of elements with a strict weak order. It works by choosing a pivot from the array, dividing the remaining elements into two partitions (one with elements less than the pivot and one with elements greater), then recursively sorting these partitions. The sorted partitions are then joined together with the pivot. The algorithm also includes a version that works in place by swapping elements within the array to avoid additional memory allocation. The pivot selection method is not specified and can vary.


Works with: Guile version 2.0.13
(define short-date
  (lambda (lt)
    (strftime "%Y-%m-%d" (localtime lt))))

(define long-date
  (lambda (lt)
    (strftime "%A, %B %d, %Y" (localtime lt))))

(define main
  (lambda (args)
    ;; Current date
    (let ((dt (car (gettimeofday))))
      ;; Short style
      (display (short-date dt))(newline)
      ;; Long style
      (display (long-date dt))(newline))))

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007".


(define (power-set set)
  (if (null? set)
      '(())
      (let ((rest (power-set (cdr set))))
        (append (map (lambda (element) (cons (car set) element))
                     rest)
                rest))))

(display (power-set (list 1 2 3)))
(newline)

(display (power-set (list "A" "C" "E")))
(newline)

implement a function that takes a set as input and returns its power set. The power set includes all subsets of the input set, including the empty set and the set itself. The function also demonstrates the handling of edge cases where the input set is empty or contains only the empty set.


The code defines a function that takes a positive integer as input and returns the Roman numeral representation of that integer. It follows the modern Roman numeral system where each digit is expressed separately, starting from the leftmost digit and excluding any digit with a value of zero. For example, 1990 is represented as MCMXC, 2008 as MMVIII, and 1666 as MDCLXVI.


(let ((array #(1 2 3 4 5))     ; vector literal
      (array2 (make-vector 5))  ; default is unspecified
      (array3 (make-vector 5 0))) ; default 0
 (vector-set! array 0 3)
 (vector-ref array 0))    ; 3

demonstrate the basic syntax of arrays in a specific programming language, including creating an array, assigning a value to it, and retrieving an element. It also showcases the use of both fixed-length and dynamic arrays, with an example of pushing a value into the array.


Character by character copy; Open ports for the input and output files
(define in-file (open-input-file "input.txt"))
(define out-file (open-output-file "output.txt"))

; Read and write characters from the input file
; to the output file one by one until end of file
(do ((c (read-char in-file) (read-char in-file)))
        ((eof-object? c))
        (write-char c out-file))

; Close the ports
(close-input-port in-file)
(close-output-port out-file)

demonstrate reading the contents of "input.txt" file into a variable and then writing this variable's contents into a new file called "output.txt".


(define s "alphaBETA")
(list->string (map char-upcase (string->list s)))
(list->string (map char-downcase (string->list s)))

> (define s "alphaBETA gammaDELTA")
> (string-upcase s)     ;; turn all into upper case
"ALPHABETA GAMMADELTA"
> (string-downcase s)   ;; turn all into lower case
"alphabeta gammadelta"
> (string-titlecase s)  ;; capitalise start of each word
"Alphabeta Gammadelta"

demonstrate the conversion of the string "alphaBETA" to upper-case and lower-case using the default string literal encoding or plain ASCII. It also showcases additional case conversion functions available in the language's library, such as swapping case or capitalizing the first letter. Note that in some languages, the toLower and toUpper functions may not be reversible. The code uses SRFI-13 for this task.


(list obj ...)

(display (list 1 2 3))
(newline)
(display (list))
(newline)

create a collection and populate it with a set of values. The code also includes examples of returning newly allocated lists with various modifications such as prepending objects and appending elements from other lists.


(call-with-current-continuation
 (lambda (esc)
   (do ((i 1 (+ 1 i))) (#f)
     (display i)
     (if (= i 10) (esc (newline)))
     (display ", "))))

(let loop ((i 0))
  (display i)
  (if (= i 10)
      (newline)
      (begin
        (display ", ")
        (loop (+ 1 i)))))

demonstrate a loop that outputs a comma-separated list from 1 to 10. Each number and comma are printed using separate output statements within the loop body. Tail recursion is used to achieve this.


(import (chezscheme))
(import (srfi srfi-1))

(define (remove-self-dependency pair)
  (let ((key (car pair))
        (value (cdr pair)))
    (cons key (remq key value))))w

(define (remove-self-dependencies alist)
  (map remove-self-dependency alist))

(define (add-missing-items dependencies)
  (let loop ((items (delete-duplicates (append-map cdr dependencies) eq?))
             (out dependencies))
    (if (null? items)
        out
        (let ((item (car items)))
          (if (assq item out)
              (loop (cdr items) out)
              (loop (cdr items) (cons (cons item '()) out)))))))

(define (lift dependencies batch)
  (let loop ((dependencies dependencies)
             (out '()))
    (if (null? dependencies)
        out
        (let ((key (caar dependencies))
              (value (cdar dependencies)))
          (if (null? value)
              (loop (cdr dependencies) out)
              (loop (cdr dependencies)
                    (cons (cons key (lset-difference eq? value batch))
                          out)))))))

(define (topological-sort dependencies)
  (let* ((dependencies (remove-self-dependencies dependencies))
         (dependencies (add-missing-items dependencies)))
    (let loop ((out '())
               (dependencies dependencies))
      (if (null? dependencies)
          (reverse out)
          (let ((batch (map car (filter (lambda (pair) (null? (cdr pair))) dependencies))))
            (if (null? batch)
                #f
                (loop (cons batch out) (lift dependencies batch))))))))

(define example
  '((des_system_lib . (std synopsys std_cell_lib des_system_lib dw02
                           dw01 ramlib ieee))
    (dw01           . (ieee dw01 dware gtech))
    (dw02           . (ieee dw02 dware))
    (dw03           . (std synopsys dware dw03 dw02 dw01 ieee gtech))
    (dw04           . (dw04 ieee dw01 dware gtech))
    (dw05           . (dw05 ieee dware))
    (dw06           . (dw06 ieee dware))
    (dw07           . (ieee dware))
    (dware          . (ieee dware))
    (gtech          . (ieee gtech))
    (ramlib         . (std ieee))
    (std_cell_lib   . (ieee std_cell_lib))
    (synopsys       . ())))

(write (topological-sort example))

(define unsortable
  '((des_system_lib . (std synopsys std_cell_lib des_system_lib dw02
                           dw01 ramlib ieee))
    (dw01           . (ieee dw01 dware gtech dw04))
    (dw02           . (ieee dw02 dware))
    (dw03           . (std synopsys dware dw03 dw02 dw01 ieee gtech))
    (dw04           . (dw04 ieee dw01 dware gtech))
    (dw05           . (dw05 ieee dware))
    (dw06           . (dw06 ieee dware))
    (dw07           . (ieee dware))
    (dware          . (ieee dware))
    (gtech          . (ieee gtech))
    (ramlib         . (std ieee))
    (std_cell_lib   . (ieee std_cell_lib))
    (synopsys       . ())))

(newline)
(write (topological-sort unsortable))

The code implements a function that performs a topological sort on VHDL libraries based on their dependencies. It ensures that no library is compiled before the ones it depends on. The function also handles cases of self-dependencies and flags un-orderable dependencies. It uses either Kahn's 1962 topological sort or depth-first search algorithm for sorting.


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

;; return all combinations of size elements from given set
(define (combinations size set unique?)
  (if (zero? size)
    (list '())
    (let loop ((base-combns (combinations (- size 1) set unique?))
               (results '())
               (items set))
      (cond ((null? base-combns) ; end, as no base-combinations to process
             results)
            ((null? items)       ; check next base-combination
             (loop (cdr base-combns)
                   results
                   set))
            ((and unique?        ; ignore if wanting list unique
                  (member (car items) (car base-combns) =))
             (loop base-combns
                   results
                   (cdr items)))
            (else                ; keep the new combination
              (loop base-combns
                    (cons (cons (car items) (car base-combns))
                          results)
                    (cdr items)))))))

;; checks if all 4 sums are the same
(define (solution? a b c d e f g)
  (= (+ a b)
     (+ b c d)
     (+ d e f)
     (+ f g)))

;; Tasks
(display "Solutions: LOW=1 HIGH=7\n")
(display (filter (lambda (combination) (apply solution? combination))
                 (combinations 7 (iota 7 1) #t))) (newline)

(display "Solutions: LOW=3 HIGH=9\n")
(display (filter (lambda (combination) (apply solution? combination))
                 (combinations 7 (iota 7 3) #t))) (newline)

(display "Solution count: LOW=0 HIGH=9 non-unique\n")
(display (count (lambda (combination) (apply solution? combination))
                (combinations 7 (iota 10 0) #f))) (newline)

The code finds all possible solutions for a 4-squares puzzle where each square sums up to the same total. It operates under two conditions: each letter representing a unique value between 1-7 and 3-9, and each letter representing a non-unique value between 0-9. The code also counts the number of non-unique solutions.


Library: Scheme/PsTk

(import (scheme base)
        (scheme inexact)
        (scheme time)
        (pstk))

(define PI 3.1415927)

;; Draws the hands on the canvas using the current time, and repeats each second
(define (hands canvas)
  (canvas 'delete 'withtag "hands")

  (let* ((time (current-second)) ; no time locality used, so displays time in GMT
         (hours (floor (/ time 3600)))
         (rem (- time (* hours 3600)))
         (mins (floor (/ rem 60)))
         (secs (- rem (* mins 60)))
         (second-angle (* secs (* 2 PI 1/60)))
         (minute-angle (* mins (* 2 PI 1/60)))
         (hour-angle (* hours (* 2 PI 1/12))))
    (canvas 'create 'line ; second hand
            100 100
            (+ 100 (* 90 (sin second-angle)))
            (- 100 (* 90 (cos second-angle)))
            'width: 1 'tags: "hands")
    (canvas 'create 'line ; minute hand
            100 100
            (+ 100 (* 85 (sin minute-angle)))
            (- 100 (* 85 (cos minute-angle)))
            'width: 3
            'capstyle: "projecting"
            'tags: "hands")
    (canvas 'create 'line ; hour hand
            100 100
            (+ 100 (* 60 (sin hour-angle)))
            (- 100 (* 60 (cos hour-angle)))
            'width: 7
            'capstyle: "projecting"
            'tags: "hands"))
  (tk/after 1000 (lambda () (hands canvas))))

;; Create the initial frame, clock frame and hours
(let ((tk (tk-start)))
  (tk/wm 'title tk "GMT Clock")

  (let ((canvas (tk 'create-widget 'canvas)))
    (tk/pack canvas)
    (canvas 'configure 'height: 200 'width: 200)
    (canvas 'create 'oval 2 2 198 198 'fill: "white" 'outline: "black")
    (do ((h 1 (+ 1 h)))
      ((> h 12) )
      (let ((angle (- (/ PI 2) (* h PI 1/6))))
        (canvas 'create 'text
                (+ 100 (* 90 (cos angle)))
                (- 100 (* 90 (sin angle)))
                'text: (number->string h)
                'font: "{Helvetica -12}")))

    (hands canvas))
  (tk-event-loop tk))

The code creates a simple, animated time-keeping device that updates every second. It can be any form of clock, such as a stopwatch, hourglass, sundial, etc., but it must clearly display the change in seconds. The code is designed to be efficient, not overusing CPU resources by unnecessary polling of the system timer. It is also written to be clear and concise, avoiding unnecessary complexity. The code includes a translation of a Tcl example that displays an analogue clock with three hands.


Works with: Gauche Scheme
(use srfi-42)

(define (py perim)
  (define prim 0)
  (values
    (sum-ec
      (: c perim) (: b c) (: a b)
      (if (and (<= (+ a b c) perim)
               (= (square c) (+ (square b) (square a)))))
      (begin (when (= 1 (gcd a b)) (inc! prim)))
      1)
    prim))

gosh> (py 100)
17
7

"Output: The code calculates the number of Pythagorean triples with a perimeter no larger than 100 and the number of these that are primitive. It also handles large values up to a maximum perimeter of 100,000,000."


Library: Scheme/PsTk
#!r6rs

;; PS-TK example: display simple frame

(import (rnrs)
        (lib pstk main) ; change this to refer to your installation of PS/Tk
        )

(define tk (tk-start))
(tk/wm 'title tk "PS-Tk Example: Frame")

(tk-event-loop tk)

"Creates an empty GUI window that can respond to close requests."


(use-modules (ice-9 format))

(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 (format-table table)
  (for-each (lambda (t) (format #t "~10s~10d~%" (car t) (cadr t))) table))

(define (print-freq filename)
  (format-table (char-freq (open-input-file filename) '())))

(print-freq "letter-frequency.scm")

#\(               45
#\u                5
#\s                9
#\e               47
#\-               19
#\m                9
#\o               16
#\d               19
#\l               25
#\space           83
#\i               15
#\c               28
#\9                1
#\f               20
#\r               39
#\a               47
#\t               36
#\)               45
#\newline         21
#\n               15
#\h               14
#\q                7
#\p                9
#\b               16
#\j                1
#\?                3
#\k                1
#\1                4
#\+                1
#\#                2
#\"                4
#\~                3
#\0                2
#\%                1
#\'                1
#\y                1
#\.                1

(with-input-from-string "foobar"
  (lambda ()
    (port-fold (lambda (x s)
                 (alist-update x
                               (add1 (alist-ref x s eq? 0))
                               s))
               '()
               read-char)))

The code opens a text file and counts the frequency of each letter. It may count all characters, including punctuation, or only letters from A to Z. The code is implemented in Guile Scheme 2.0.11 and CHICKEN Scheme, and the output is displayed in no particular order. An example output from reading its own source is shown as ((#\f . 1) (#\o . 2) (#\b . 1) (#\a . 1) (#\r . 1)).


(cons value next)

(car my-list) ; returns the first element of the list
(cdr my-list) ; returns the remainder of the list

(set-car! my-list new-elem)
(set-cdr! my-list new-next)

define a data structure for a singly-linked list element. This element holds a numeric value and a mutable link to the next element. The element, also known as a cons-pair in Lisp dialects, can be constructed, deconstructed, and mutated using specific functions.


(import (scheme base)
        (scheme file)
        (scheme inexact)
        (scheme write))

(define *scale* 10) ; controls overall size of tree
(define *split* 20) ; controls angle of split (in degrees)

;; construct lines for tree as list of 5-tuples (x1 y1 x2 y2 depth)
;; - x1 y1 is start point
;; - angle of this line, in radians
;; - depth, depth within tree (controls length of line)
(define (create-tree x1 y1 angle depth)
  (define (degrees->radians d)
    (let ((pi 3.14159265358979323846264338327950288419716939937510582097))
      (* d pi 1/180)))
  ;
  (if (zero? depth)
    '()
    (let ((x2 (+ x1 (* (cos (degrees->radians angle)) depth *scale*)))
          (y2 (+ y1 (* (sin (degrees->radians angle)) depth *scale*))))
      (append (list (map truncate (list x1 y1 x2 y2 depth)))
              (create-tree x2 y2 (- angle *split*) (- depth 1))
              (create-tree x2 y2 (+ angle *split*) (- depth 1))))))

;; output the tree to an eps file
(define (output-tree-as-eps filename tree)
  (when (file-exists? filename) (delete-file filename))
  (with-output-to-file
    filename
    (lambda ()
      (display "%!PS-Adobe-3.0 EPSF-3.0\n%%BoundingBox: 0 0 800 800\n")

      ;; add each line - sets linewidth based on depth in tree
      (for-each (lambda (line)
                  (display
                    (string-append "newpath\n"
                                   (number->string (list-ref line 0)) " "
                                   (number->string (list-ref line 1)) " "
                                   "moveto\n"
                                   (number->string (list-ref line 2)) " "
                                   (number->string (list-ref line 3)) " "
                                   "lineto\n"
                                   (number->string (truncate (/ (list-ref line 4) 2)))
                                   " setlinewidth\n"
                                   "stroke\n"
                                   )))
                tree)
      (display "\n%%EOF"))))

(output-tree-as-eps "fractal.eps" (create-tree 400 200 90 9))

The code generates a fractal tree by drawing a trunk, splitting it at the end at a certain angle to form branches, and repeating this process until a desired level of branching is reached. The tree is represented as a list of line segments and is output to an EPS file.


(define (factors n)
  (define (*factors d)
    (cond ((> d n) (list))
          ((= (modulo n d) 0) (cons d (*factors (+ d 1))))
          (else (*factors (+ d 1)))))
  (*factors 1))

(display (factors 1111111))
(newline)

calculate the factors of a positive integer using a trial division algorithm. The factors are the positive integers that can divide the input number to yield a positive integer result. The code does not handle cases of zero or negative integers. For prime numbers, the factors will be 1 and the number itself.


(import (scheme base)
        (scheme write)
        (srfi 1)
        (except (srfi 13) string-for-each string-map)
        (srfi 14))

;; text is a list of lines, alignment is left/right/center
;; displays the aligned text in columns with a single space gap
(define (align-columns text alignment)
  (define (split line) ; splits string on $ into list of strings
    (string-tokenize line (char-set-complement (->char-set "$"))))
  (define (extend lst n) ; extends list to length n, by adding "" to end
    (append lst (make-list (- n (length lst)) "")))
  (define (align-word word width) ; align single word to fit width
    (case alignment
      ((left) (string-pad-right word width))
      ((right) (string-pad word width))
      ((center) (let ((rem (- width (string-length word))))
                  (string-pad-right (string-pad word (- width (truncate (/ rem 2))))
                                    width)))))
  ;
  (display alignment) (newline)
  (let* ((text-list (map split text))
         (max-line-len (fold (lambda (text val) (max (length text) val)) 0 text-list))
         (text-lines (map (lambda (line) (extend line max-line-len)) text-list))
         (min-col-widths (map (lambda (col)
                                (fold (lambda (line val)
                                        (max (string-length (list-ref line col))
                                             val))
                                      0
                                      text-lines))
                              (iota max-line-len))))
    (map (lambda (line)
           (map (lambda (word width)
                  (display (string-append (align-word word width)
                                          " ")))
                line min-col-widths)
           (newline))
         text-lines))
  (newline))

;; show example
(define *example*
  '("Given$a$text$file$of$many$lines,$where$fields$within$a$line$"
    "are$delineated$by$a$single$'dollar'$character,$write$a$program"
    "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$"
    "column$are$separated$by$at$least$one$space."
    "Further,$allow$for$each$word$in$a$column$to$be$either$left$"
    "justified,$right$justified,$or$center$justified$within$its$column."))

(align-columns *example* 'left)
(align-columns *example* 'center)
(align-columns *example* 'right)

The code reads a text file with lines separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. It also allows each word in a column to be left, right, or center justified. The minimum space between columns is computed from the text, not hard-coded. Trailing dollar characters or consecutive spaces at the end of lines do not affect the alignment. The output is suitable for viewing in a mono-spaced font on a plain text editor or basic terminal.


(define (rot13 str)
  (define (rot13-char c)
    (integer->char (+ (char->integer c)
                      (cond ((and (char>=? c #\a) (char<? c #\n))
                             13)
                            ((and (char>=? c #\A) (char<? c #\N))
                             13)
                            ((and (char>=? c #\n) (char<=? c #\z))
                             -13)
                            ((and (char>=? c #\N) (char<=? c #\Z))
                             -13)
                            (else
                             0)))))
  (list->string (map rot13-char (string->list str))))
Works with: Chibi-Scheme
Works with: Chicken Scheme
Works with: Gambit Scheme
Works with: Gauche
Works with: Guile

fewer redundant tests
loops over input lines
conforms to R7RS
;; Works with: chibi, csi, gosh, gsi, guile
(cond-expand
 (r7rs (import (scheme base)
               (scheme write)))
 (gambit)
 (chicken (import (r7rs))))

(define char-rot13
  (let* ((A (char->integer #\A))
         (N (char->integer #\N))
         (Z (char->integer #\Z))
         (a (char->integer #\a))
         (n (char->integer #\n))
         (z (char->integer #\z))
         (inc 13)
         (dec (- inc))
         (rot (lambda (c direction)
                (integer->char (+ c direction)))))
    (lambda (ch)
      (let ((c (char->integer ch)))
        (if (>= c A)
            (if (< c N)
                (rot c inc)
                (if (<= c Z)
                    (rot c dec)
                    (if (>= c a)
                        (if (< c n)
                            (rot c inc)
                            (if (<= c z)
                                (rot c dec)
                                ch))))))))))

(define (string-rot13 str)
  (string-map char-rot13 str))

(if (not (and (string=? (string-rot13 "abcdefghijklmnopqrstuvwxyz")
                        "nopqrstuvwxyzabcdefghijklm")
              (string=? (string-rot13 "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
                        "NOPQRSTUVWXYZABCDEFGHIJKLM")))
    (error "Test failed."))

(let loop ((line (read-line)))
  (if (string? line)
      (begin
        (display (string-rot13 line))
        (newline)
        (loop (read-line)))))

The code implements a rot-13 function, which is a simple mono-alphabetic substitution cipher that replaces each letter of the ASCII alphabet with the letter rotated 13 characters around the 26 letter alphabet. The function preserves case and passes all non-alphabetic characters in the input stream through without alteration. It can be optionally wrapped in a utility program that performs line-by-line rot-13 encoding of every line of input from specified files or standard input, similar to a common UNIX utility. This function is commonly used for obfuscating text to prevent casual reading of spoilers or offensive material.


demonstrate how to use nested for loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop, resulting in a pattern of increasing asterisks.