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, and, 9) and ARMSchembler and compiler for Armpit Scheme. These examples are similar to those of previous snapshots but updated for this version, where applicable. 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 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). Once the code has been evaluated, the system prompt becomes that produced by this user-defined (prompt) function rather than the built-in (prompt) primitive.
; Armpit Scheme Prompt Example
; tested on LPC-H2214, LPC-H2888, CS-E9302, TCT-Hammer, TI-Beagle
; example prompt
(begin
(define prst
(string-append " aps" version "> "))
(define (prompt) (write (bitwise-arithmetic-shift (gc) -3)) (display prst)))
The code below examplifies writing to and reading from files, listing files, erasing all files and unlocking the file system (if it remained locked due to a multitasking crash). It is the same as in the previous snapshot. Also, note that for the OMAP3530 Live-SD version (BeagleBoard and Overo Tide), files are written to and read from SD-card (native file system for those MCUs), and there is no (erase) function (that erases all files).
; Armpit Scheme File Example
; tested on LPC-H2214, LPC-H2888, CS-E9302, STM32-H103, LM3S1968-EVB, TI-Beagle
; unlock file system (optional - file system may get locked during read/write errors)
(unlock)
; erase all files (optional - may take a few seconds -- not available on OMAP3530)
(erase)
; list all files
(files)
; write some data to a file named zag
(let ((port (open-output-file "zag")))
(if (zero? port) #f
(begin
(write "hello" port)
(display #\space port)
(write '(1 2 3) port)
(display #\space port)
(write 3.4e-2 port)
(display #\space port)
(write (make-vector 140 123456) port)
(close-output-port port))))
; list all files
(files)
; read and display data from a file named zag
(let ((port (open-input-file "zag")))
(if (zero? port) #f
(let loop ((val (read port)))
(if (eof-object? val)
(close-input-port port)
(begin
(if (not (vector? val))
(write val)
(begin
(write (vector-length val))
(write (vector-ref val 0))
(write (vector-ref val (- (vector-length val) 1)))))
(newline)
(loop (read port)))))))
The code below adapts the above example to the case of writing and reading to an SD-card (for boards where the interface is implemented). The SD card file system is FAT16, with 8.3 file names, limited to 2 GB (max) cards, and ARMPit Scheme knows only about the top-level directory of this file system. The built-in SD-card port is named SDFT.
; Armpit Scheme SD-card File Example
; tested on LPC-H2214, CS-E9302, STM32-H103, LM3S6965-EVB, SFE-Logomatic2
; initialize communications with the card (repeat until non-#f)
(sd-init)
; list all files on SD card
(files SDFT)
; write some data to a file named zag on the SD card
(let ((port (open-output-file "zag" SDFT)))
(if (zero? port) #f
(begin
(write "hello" port)
(display #\space port)
(write '(1 2 3) port)
(display #\space port)
(write 3.4e-2 port)
(display #\space port)
(write (make-vector 140 123456) port)
(close-output-port port))))
; list all files on the SD card
(files SDFT)
; read and display data from a file named zag on the SD card
(let ((port (open-input-file "zag" SDFT)))
(if (zero? port) #f
(let loop ((val (read port)))
(if (eof-object? val)
(close-input-port port)
(begin
(if (not (vector? val))
(write val)
(begin
(write (vector-length val))
(write (vector-ref val 0))
(write (vector-ref val (- (vector-length val) 1)))))
(newline)
(loop (read port)))))))
The code below adapts the first library example given in section 7.3 of r6rs to ArmPit Scheme. The modifications are mainly related to the lack of "rename", "only" and "prefix" forms in this version.
; Armpit Scheme Party Library Example
; Tested on SFE-Logomatic V2.0
; build the stack library
(library
(stack)
(export stack:make stack:push! stack:pop! stack:empty!)
(import (rnrs))
(define (stack:make) (list '()))
(define (stack:push! s v) (set-car! s (cons v (car s))))
(define (stack:pop! s)
(let ((v (caar s)))
(set-car! s (cdar s))
v))
(define (stack:empty! s) (set-car! s '())))
; build the balloons library
(library
(balloons)
(export balloon:make balloon:push balloon:pop)
(import (rnrs))
(define (balloon:make w h) (cons w h))
(define (balloon:push b amt)
(cons (- (car b) amt) (+ (cdr b) amt)))
(define (balloon:pop b) (display "Boom! ")
(display (* (car b) (cdr b)))
(newline)))
; build the party library
(library
(party)
(export make push push! make-party pop!)
(import (rnrs) (stack) (balloons))
(define make balloon:make)
(define push balloon:push)
(define push! stack:push!)
(define (make-party)
(let ((s (stack:make)))
(push! s (balloon:make 10 10))
(push! s (balloon:make 12 9))
s))
(define (pop! p)
(balloon:pop (stack:pop! p))))
; list all libraries (00.0241-style)
(map (lambda (e) (list (vector-ref (vector-ref e 0) 0))) (vector-ref (_GLV) 12))
; list all libraries (050-style)
(libs)
; import the party library
(import (party))
; have a party (test program)
(begin
(define p (make-party))
(pop! p) ; displays "Boom! 108"
(push! p (push (make 5 5) 1))
(pop! p)) ; displays "Boom! 24"
; de-import all libraries
(import)
; erase the party library from flash (re-list all libs to check)
(erase -1)
; erase all libs from flash (00.0241-style, re-list all libs to check)
(erase -536870912)
; erase all libs from flash (050-style, re-list all libs to check)
(erase-libs)
The code below is the Runge-Kutta solution of a system of Ordinary Differential Equations (ODEs) representing a simple oscillator that is given on page 44 of the Revised^5 Report on the Algorithmic Language Scheme (r5rs). A helper function to drive the code is given at the end. This example is the same as in all prior versions of Armpit Scheme.
; Armpit Scheme Runge-Kutta Example (R5RS p. 44)
; Tested on Tiny2138, SFE-Logomatic, LPC-H2148, LCDDemo-2158, Tiny2106,
; LPC-H2214, SAM7-H256, STR-H711, LPC-H2888, CS-E9302,
; LM3S1968-EVB, TI-Beagle
(define integrate-system
(lambda (system-derivative initial-state h)
(let ((next (runge-kutta-4 system-derivative h)))
(letrec ((states
(cons initial-state
(delay (map-streams next states)))))
states))))
; There is no need to paste this in two chunks to avoid errors anymore
(define runge-kutta-4
(lambda (f h)
(let ((*h (scale-vector h))
(*2 (scale-vector 2))
(*1/2 (scale-vector (/ 1 2)))
(*1/6 (scale-vector (/ 1 6))))
(lambda (y)
(let* ((k0 (*h (f y)))
(k1 (*h (f (add-vectors y (*1/2 k0)))))
(k2 (*h (f (add-vectors y (*1/2 k1)))))
(k3 (*h (f (add-vectors y k2)))))
(add-vectors
y (*1/6 (add-vectors k0 (*2 k1) (*2 k2) k3))))))))
(define elementwise
(lambda (f)
(lambda vectors
(generate-vector
(vector-length (car vectors))
(lambda (i)
(apply f
(map (lambda (v) (vector-ref v i))
vectors)))))))
(define generate-vector
(lambda (size proc)
(let ((ans (make-vector size)))
(letrec ((loop
(lambda (i)
(cond ((= i size) ans)
(else
(vector-set! ans i (proc i))
(loop (+ i 1)))))))
(loop 0)))))
(define add-vectors (elementwise +))
(define scale-vector
(lambda (s)
(elementwise (lambda (x) (* x s)))))
(define map-streams
(lambda (f s)
(cons (f (head s))
(delay (map-streams f (tail s))))))
(define head car)
(define tail
(lambda (stream) (force (cdr stream))))
(define damped-oscillator
(lambda (R L C)
(lambda (state)
(let ((Vc (vector-ref state 0))
(I1 (vector-ref state 1)))
(vector (- 0 (+ (/ Vc (* R C)) (/ I1 C)))
(/ Vc L))))))
(define the-states
(integrate-system
(damped-oscillator 10000 1000 .001)
'#(1 0)
.01))
; function to compute the solution for a given time span
(define oscillate
(lambda (steps)
(let loop ((n steps) (r the-states))
(and (>= n 0)
(write (- steps n))
(write (head r))
(newline)
(loop (- n 1) (tail r))))))
; compute the solution
(oscillate 10)
(oscillate 50)
(oscillate 100)
The code below is the library version of the Runge-Kutta example presented above. It is adapted from the library example presented in Appendix D of the r6rs. The code has been modified from the r6rs example to use delay/force as in the r5rs example rather than lambdas (as in the r6rs example) because the former leads to markedly faster execution in the ArmPit Scheme interpreter (the same was observed in guile 1.7.1 for a non-library based implementation). It is the same as in the previous snapshot.
; Armpit Scheme Runge-Kutta Library Example (R6RS Appendix D)
; Tested on SFE-Logomatic V2.0
; build the runge-kutta library
(library
(runge-kutta)
(export integrate-system head tail)
(import)
;; library body
(define integrate-system
(lambda (system-derivative initial-state h)
(let ((next (runge-kutta-4 system-derivative h)))
(letrec ((states
(cons initial-state
(delay (map-streams next states)))))
states))))
(define runge-kutta-4
(lambda (f h)
(let ((*h (scale-vector h))
(*2 (scale-vector 2))
(*1/2 (scale-vector (/ 1 2)))
(*1/6 (scale-vector (/ 1 6))))
(lambda (y)
;; y is a system state
(let* ((k0 (*h (f y)))
(k1 (*h (f (add-vectors y (*1/2 k0)))))
(k2 (*h (f (add-vectors y (*1/2 k1)))))
(k3 (*h (f (add-vectors y k2)))))
(add-vectors y
(*1/6 (add-vectors k0
(*2 k1)
(*2 k2)
k3))))))))
(define elementwise
(lambda (f)
(lambda vectors
(generate-vector
(vector-length (car vectors))
(lambda (i)
(apply f
(map (lambda (v) (vector-ref v i))
vectors)))))))
(define generate-vector
(lambda (size proc)
(let ((ans (make-vector size)))
(letrec ((loop
(lambda (i)
(cond ((= i size) ans)
(else
(vector-set! ans i (proc i))
(loop (+ i 1)))))))
(loop 0)))))
(define add-vectors (elementwise +))
(define scale-vector
(lambda (s)
(elementwise (lambda (x) (* x s)))))
(define map-streams
(lambda (f s)
(cons (f (head s))
(delay (map-streams f (tail s))))))
(define head car)
(define tail
(lambda (stream) (force (cdr stream)))))
; list all libraries (as a check, 00.0241-style)
(map (lambda (e) (list (vector-ref (vector-ref e 0) 0))) (vector-ref (_GLV) 12))
; list all libraries (as a check, 050-style)
(libs)
; import the runge-kutta library
(import (runge-kutta))
(define damped-oscillator
(lambda (R L C)
(lambda (state)
(let ((Vc (vector-ref state 0))
(Il (vector-ref state 1)))
(vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
(/ Vc L))))))
(define the-states
(integrate-system
(damped-oscillator 10000 1000 .001)
'#(1 0)
.01))
; function to compute the solution for a given time span
(define oscillate
(lambda (steps)
(let loop ((n steps) (r the-states))
(and (>= n 0)
(write (- steps n))
(write (head r))
(newline)
(loop (- n 1) (tail r))))))
; compute the solution
(oscillate 10)
(oscillate 50)
(oscillate 100)
The code below provides two examples of Fast Fourier Transform computation. The examples are the same as in the previous snapshot. The first example is adapted for complex numbers from the FFT example provided in the Gambit-C Scheme benchmarks here, and side-effects the input data vector. The second example is adapted from a Scheme Workshop entry by John David Stone and preserves the input data vector.
; Armpit Scheme FFT Example
; Tested on SFE-Logomatic V2.0
; Example 1: FFT adapted from Gambit-C Scheme benchmarks
; modified for complex numbers
; define pi
(define pi (* 4 (atan 1)))
; forward FFT function
(define (four2 data)
(let ((n (vector-length data)))
(let loop1 ((i 0) (j 0))
(if (< i n)
(begin
(if (< i j)
(let ((temp (vector-ref data i)))
(vector-set! data i (vector-ref data j))
(vector-set! data j temp)))
(let loop2 ((m (bitwise-arithmetic-shift n -1)) (j j))
(if (and (>= m 2) (>= j m))
(loop2 (bitwise-arithmetic-shift m -1) (- j m))
(loop1 (+ i 1) (+ j m)))))))
(let loop3 ((mmax 1))
(if (< mmax n)
(let ((wp (- (make-polar 1 (/ pi mmax)) 1)))
(let loop4 ((w 1.0) (m 0))
(if (< m mmax)
(begin
(let loop5 ((i m))
(if (< i n)
(let* ((j (+ i mmax))
(temp (* w (vector-ref data j))))
(vector-set! data j (- (vector-ref data i) temp))
(vector-set! data i (+ (vector-ref data i) temp))
(loop5 (+ j mmax)))))
(loop4 (+ (* w wp) w) (+ m 1)))))
(loop3 (* mmax 2)))))))
; simple data set, 32 real values
(define data
(let ((d (make-vector 32)))
(let loop ((n 0))
(if (> n 31) d
(begin
(vector-set! d n (+ 1/3 (cos (* (/ 2 32) 2 pi n))))
(loop (+ n 1)))))))
; forward transform -- this side-effects data
(four2 data)
; view result
data
; Example 2: FFT adapted from Scheme Workshop code by John David Stone
; define pi
(define pi (* 4 (atan 1)))
(define fft
(let ((unshuffle
(lambda (seq)
(let loop ((rest seq)
(evens '())
(odds '()))
(if (null? rest)
(cons (reverse evens) (reverse odds))
(loop (cddr rest)
(cons (car rest) evens)
(cons (cadr rest) odds)))))))
(lambda (sequence)
(let ((len (length sequence)))
(if (= len 1)
sequence
(let ((nth-root (make-polar 1 (/ (* 2 pi) len)))
(half-len (quotient len 2))
(packs (unshuffle sequence)))
(let loop ((step 0)
(root 1)
(evens (fft (car packs)))
(odds (fft (cdr packs)))
(front '())
(rear '()))
(if (= step half-len)
(append (reverse front) (reverse rear))
(loop (+ step 1)
(* root nth-root)
(cdr evens)
(cdr odds)
(cons (+ (car evens) (* root (car odds)))
front)
(cons (- (car evens) (* root (car odds)))
rear))))))))))
; simple data set, 32 real values
(define data2
(let ((d (make-vector 32)))
(let loop ((n 0))
(if (> n 31) (vector->list d)
(begin
(vector-set! d n (+ 1/3 (cos (* (/ 2 32) 2 pi n))))
(loop (+ n 1)))))))
; perform FFT
(fft data2)
; get magnitude of Fourier components
(map magnitude (fft data2))
This Expert System example is the same as in the previous snapshot.
; Armpit Scheme Expert System Example
; Tested on SFE-Logomatic V2.0
; 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 `(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
The ARMSchembler presented here is a mild update of that of the previous snapshot. It is designed to be loaded from an SD card and to be used with the linker that is in the 050 core.
After copying the ARMSchembler source file to a SD card on your development system, place the card in an ArmPit Scheme system, reset it (if desired or needed), initialize the SD sub-system (if needed) and install the ARMSchembler:
ap> (sd-init) ; check for #t or #vu8(...), redo if #f (not needed on OMAP3530)
ap> (load "asar_050.scm" SDFT) ; for ARM (omit SDFT on OMAP3530 Live-SD)
ap> (libs) ; check for (as) ... to verify installation
OR:
ap> (sd-init) ; check for #t or #vu8(...), redo if #f (not needed on OMAP3530)
ap> (load "asT2_050.scm" SDFT) ; for Cortex-M3 (Thumb2)
ap> (libs) ; check for (as) ... to verify installation
The Compiler for ArmPit Scheme (caps) library is also a mild update of the
compiler for 00.0250.
The main modification is in branches to built-in functions
with common pre-entry procedures, applied when the immutable-primitives flag is
used:
ap> (load "caps_050.scm" SDFT) ; all architectures (omit SDFT on OMAP3530 Live-SD)
ap> (libs) ; check for (caps) ... to verify installation
ARMSchembler and Compiler initialization and tests are presented here: