This page presents examples of: 1) changing the prompt, 2) reading and writing files, 3) using files on an attached SD-card, 4) using r6rs-style libraries, 5) the Runge-Kutta example of r5rs, 6) the library-based Runge-Kutta example of r6rs, 7) Fast Fourier Transforms (FFT), 8) an expert system, 9) the game of life (Conway), and 10) an ARMSchembler and compiler for Armpit Scheme. Examples that differ from prior releases are presented in full (eg. prompt, expert system and life) while those that are the same are linked to the appropriate web page. The ARMSchembler and compiler for Armpit Scheme have not yet been updated for this release. Several examples do not work out-of-the-box on small MCUs (NXP LPC-1343, 2103, 2131) due to the absence of macros and of the r5rs library on these chips (eg. let, string-append). It is left as an exercise to the reader to modifiy them for this purpose, if desired. Examples of GPIO, Threads, ADC, PWM and other hardware-oriented processes (if available) are presented in a separate page of MCU-specific examples.
The code below examplifies how to modify the Armpit Scheme prompt. It re-defines the (prompt) function to get a version number, and uses (gc) to find the number of free bytes, and prints those out on the current-output-port (the number of free bytes is divided by eight using a bitwise-arithmetic-shift so that the number of free cons cells is actually displayed). In prior versions, once the code was evaluated, the system prompt became that produced by this user-defined (prompt) function rather than the built-in (prompt) primitive. In 060 however, if the fast_lambda_lkp option is used (i.e. in non-small MCUs), the startup rep will intern the location of the built-in prompt variable binding as soon as the system starts and the new user-defined prompt will be ignored. To remedy this, one needs to redefine the rep (just once) after the first user-environment binding for prompt has been established. The following code exemplifies:
; Armpit Scheme Prompt Example
; tested on TI-Beagle-XM
; example prompt
(begin
(define prst
(string-append " aps" version "> "))
(define (prompt) (write (bitwise-arithmetic-shift (gc) -3)) (display prst)))
; re-define the rep
(begin
(write (call/cc (lambda (k) (set! _catch k)))) ; establish a top-level catch
(define (_prg) (write-char #\newline) (prompt) (write (eval (read) (interaction-environment))) (_prg))
(_prg))
; another example prompt (no rep re-re-definition needed)
(define (prompt) (display "zigzag> "))
This example is the same as in version 050
This example is the same as in version 050
This example is the same as in version 050
This example is the same as in version 050
This example is the same as in version 050
This example is the same as in version 050
This Expert System example is the same as in the previous releases except for the definition of the function bind!. In 060, the evaluator no longer expands macros (they are only expanded automatically by the reader but can also be expanded manually using the expand syntax-procedure). Accordingly the use of the user-defined macro (set ...) in bind! requires an additional macro expansion step when compared to version 050.
; Armpit Scheme Expert System Example
; Tested on TI-Beagle-XM
; utility function for printed output
(define (writeln . expr)
(display-all expr))
; utility function for printed output
(define (display-all lst)
(if (null? lst)
(newline)
(begin
(display (car lst))
(display-all (cdr lst)))))
; initial function that defines what to do when query fails
(define (fail) #f)
; current depth of chaining over rules
(define chain-depth 0)
; function to delay evaluation of alternatives
(define (cdelay fn)
(let ((hold-fail fail))
(set! fail
(lambda ()
(set! fail hold-fail)
(fn)))))
; function to pick one of several alternatives
(define (amb . expr-list)
(call/cc
(lambda (return)
(for-each
(lambda (expr)
(cdelay (lambda () (return expr))))
expr-list)
(fail))))
; helper macro to temporarily set the value of a variable
(define-syntax set
(syntax-rules ()
((_ var val)
(let ((local-save var))
(cdelay (lambda () (set! var local-save) (amb)))
(set! var val)))))
; function to temporarily set the value of a variable
(define (bind! var expr)
(eval (eval `(expand (set ,var ',expr)))))
; function to identify whether a variable is bound
; uses (interaction-environment) to define 'new' vars
(define (bound? var)
(or (defined? var)
(eval `(define ,var 'UNASSIGNED) (interaction-environment)))
(not (eq? (eval var) 'UNASSIGNED)))
; function to identify whether an expression is a variable
(define (variable? expr)
(and
(symbol? expr)
(eq? #\?
(string-ref (symbol->string expr) 0))))
; function to identify whether an expression is a rule
(define (rule? expr)
(and (pair? expr)
(equal? (cadr expr) ':-)))
; function to substitute variable-bindings into an expression
(define (subst-bindings form)
(cond ((pair? form)
(cons (subst-bindings (car form))
(subst-bindings (cdr form))))
((variable? form)
(if (bound? form)
(subst-bindings (eval form))
form))
(else form)))
; function to unify two expressions
(define (unify pattern1 pattern2)
(cond
((equal? pattern1 pattern2) #t)
((and (pair? pattern1) (pair? pattern2))
(and
(unify (car pattern1) (car pattern2))
(unify (cdr pattern1) (cdr pattern2))))
((variable? pattern1)
(if (bound? pattern1)
(unify (eval pattern1) pattern2)
(and
(no-self-ref? pattern1 pattern2)
(bind! pattern1 pattern2))))
((variable? pattern2)
(unify pattern2 pattern1))
(else (amb))))
; function to identify whether self-references exist in an expression
(define (no-self-ref? var expr)
(cond ((equal? var expr) (amb))
((pair? expr)
(and (no-self-ref? var (car expr))
(no-self-ref? var (cdr expr))))
((variable? expr)
(or (not (bound? expr))
(no-self-ref? var (eval expr))))
(else #t)))
; function to evaluate a knowledge-base query
(define (qeval query kb)
(or (eq? query #t)
(let ((kb-item (apply amb kb)))
(if (rule? kb-item)
(let ((clean-rule (rename-vars kb-item)))
(unify query (car clean-rule))
(set chain-depth (+ 1 chain-depth))
(and-query (cddr clean-rule) kb))
(unify query kb-item)))))
; function to evaluate an and query
(define (and-query pattern-list kb)
(or (null? pattern-list)
(and (qeval (car pattern-list) kb)
(and-query (cdr pattern-list) kb))))
; function to rename the variables in an expression
(define (rename-vars expr)
(cond
((pair? expr)
(cons
(rename-vars (car expr))
(rename-vars (cdr expr))))
((variable? expr)
(string->symbol
(string-append
(symbol->string expr)
(number->string chain-depth))))
(else expr)))
; function to find all true resolutions of a query
(define (all query . kbase)
(let ((kb (if (null? kbase) *knowledge-base* (car kbase))))
(and (qeval query kb)
(writeln (subst-bindings query))
(amb))))
; a basic fact base for testing
(define *fact-base*
'((parent john joe)
(parent john jim)
(parent julie joe)
(parent jill jim)
(parent julie john)
(parent jim bill)
(parent jim jill)
(parent joe alice)
(parent joe linda)
(male john)
(male joe)
(male jim)
(male bill)
(female jill)
(female julie)
(female alice)
(female linda)))
; a basic rule base for testing
(define *rule-base*
'(((mother ?x ?y) :- (female ?x) (parent ?x ?y))
((father ?x ?y) :- (male ?x) (parent ?x ?y))
((daughter ?x ?y) :- (female ?x) (parent ?y ?x))
((son ?x ?y) :- (male ?x) (parent ?y ?x))
((grandparent ?x ?z) :- (parent ?x ?y) (parent ?y ?z))
((grandmother ?x ?z) :- (mother ?x ?y) (parent ?y ?z))
((grandfather ?x ?z) :- (father ?x ?y) (parent ?y ?z))))
; define the knowledge base used for testing
(define *knowledge-base*
(append *fact-base* *rule-base*))
; examples of basic queries
(all '(father ?x ?y))
(all '(father ?x ?x))
(all '(mother ?x ?y))
(all '(parent ?x joe))
(all '(grandparent ?x alice))
(all '(grandfather ?x alice))
(all '(grandfather ?x linda))
(all '(?x jim ?y))
(all '(grandparent ?x ?x))
(all '(son ?x ?y))
(all '(son jim ?x))
(all '(son ?x jim))
(all '(daughter ?x joe))
(all '(?x ?y ?z)) ; find every ternary relation that can be infered
This example is an adaptation of the library example presented in section 5.6.2 of R7RS (Revised 7 Report on the Algorithmic Language Scheme) draft 8, edited by A. Shinn, J. Cowan and A.A. Gleckler (December 9, 2012). It implements Conway's Game of Life on a rectangular grid and displays cell state "graphically" using ascii characters on a VT-100 terminal (eg. minicom, TeraTerm). The present adaptation is not in library form and includes components of VT-100 control adapted from the Programming Praxis web site.
; Armpit Scheme Game of Life Example
; Tested on TI-Beagle-XM
; VT-100 utility definitions (adapted from Programming Praxis)
(begin
(define esc (integer->char 27))
(define (cls) (for-each write-char (list esc #\[ #\2 #\J)))
(define (erase-eol) (for-each write-char (list esc #\[ #\K)))
(define (goto r c)
(write-char esc)
(write-char #\[)
(display r)
(write-char #\;)
(display c)
(write-char #\H)))
; Grid building functions (adapted from R7RS Draft 8)
(begin
;; Create an NxM grid.
(define (make n m)
(let ((grid (make-vector n)))
(do ((i 0 (+ i 1)))
((= i n) grid)
(let ((v (make-vector m #false)))
(vector-set! grid i v)))))
(define (rows grid)
(vector-length grid))
(define (cols grid)
(vector-length (vector-ref grid 0)))
;; Return #f if out of range.
(define (ref grid n m)
(and (< -1 n (rows grid))
(< -1 m (cols grid))
(vector-ref (vector-ref grid n) m)))
(define (put! grid n m v)
(vector-set! (vector-ref grid n) m v))
(define (each grid proc)
(do ((j 0 (+ j 1)))
((= j (rows grid)))
(do ((k 0 (+ k 1)))
((= k (cols grid)))
(proc j k (ref grid j k)))))
(define (each2 grid1 grid0 proc)
(do ((j 0 (+ j 1)))
((= j (rows grid1)))
(do ((k 0 (+ k 1)))
((= k (cols grid1)))
(proc j k (ref grid1 j k) (ref grid0 j k))))))
; Game of Life (adapted from R7RS Draft 8)
(begin
(define (life-count grid i j)
(define (count i j)
(if (ref grid i j) 1 0))
(+ (count (- i 1) (- j 1))
(count (- i 1) j)
(count (- i 1) (+ j 1))
(count i (- j 1))
(count i (+ j 1))
(count (+ i 1) (- j 1))
(count (+ i 1) j)
(count (+ i 1) (+ j 1))))
(define (life-alive? grid i j)
(case (life-count grid i j)
((3) #t)
((2) (ref grid i j))
(else #f)))
(define (life-print2 grid1 grid0)
(each2 grid1 grid0
(lambda (i j v1 v0)
(if (not (eq? v1 v0))
(begin
(goto (+ i 1) (+ j 1))
(write-char (if v1 #\o #\ ))
(goto (+ 1 (rows grid1)) 1))))))
(define (life grid iterations)
(cls)
(life-print2 grid (make (rows grid) (cols grid)))
(do
((i 0 (+ i 1))
(grid0 grid grid1)
(grid1 (make (rows grid) (cols grid)) grid0))
((= i iterations))
(each grid0
(lambda (j k v)
(put! grid1 j k (life-alive? grid0 j k))))
(life-print2 grid1 grid0))))
; Build grid and run glider (adapted from R7RS Draft 8)
(begin
(define grid (make 20 20))
(put! grid 1 1 #t)
(put! grid 2 2 #t)
(put! grid 3 0 #t)
(put! grid 3 1 #t)
(put! grid 3 2 #t)
(life grid 60))
The ARMSchembler and compiler have not yet been updated for this release.