This is a program update for I2C communication in a distributed processing framework where the slave device is meant to read (from i2c), evaluate and print (to i2c) a Scheme expression sent by a remote device. Version 00.0098 of Armpit Scheme uses an updated strategy to internally pass environments between functions and requires explicit specification of the proper environment to use when evaluating remote expressions via eval. This environment is obtained by using the (interaction-environment) function. The code below examplifies how (interaction-environment) is used for this purpose in the boot code of a slave device meant for remote evaluation applications. It is designed for the LPC-H2148 but is easily adapted to other MCUs by comparing it to examples for prior Armpit Scheme versions. The code of the master device does not need any modification.
; Armpit Scheme I2C Communication Example 2: Code for Remote Evaluation by the Slave Device
; Updated and tested on LPC-H2148
(let ((port (open-output-file "boot")))
(if (zero? port) #f
(begin
(define (current-output-port) port)
(write
'(begin
(write 40 #xE001C000 #x0C)
(define i2c #xE001C000)
(define (current-input-port) i2c)
(define (current-output-port) i2c)
(define pinsel #xE002C000)
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0)
(write 47 i2c #x10)
(write 103 i2c #x14)
(write #x28 i2c #x18)
(write #x44 i2c #x00)))
(write
'(let rep ()
(write (eval (read) (interaction-environment)))
(rep)))
(close-output-port (current-output-port)))))
The Expert System example of versions 00.0017-00.0065 needs a minimal modification in version 00.0098. The modification is needed because of the updated environment passing technique used in the latest Armpit Scheme. It takes place in the function 'bound?' where new symbols of the form '?x' are initialized to unassigned variables if they were not previously defined. The definition of these symbols needs to take place in the interaction environment. The full code of the Expert System example is given below with the updated version of the function 'bound?'.
; Armpit Scheme Expert System Example
; Tested on Tiny2106
; 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 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))