The status of General Purpose Input/Output (GPIO) lines of the MCU can be read and modified using Armpit Scheme's extended read and write functions. These functions read/write from/to a register when both a port and a register offset are included in their argument list. The port is an integer representing the MCU-defined base address of the GPIO line to read (#xE0028000 for gpio0 and #xE0028010 for gpio1, from the LPC2138 user's manual). The register offset is also an integer and equals the offset of the register to read/write from/to relative to the port's base address (#x00 for IOxPIN, #x04 for IOxSET and #x0C for IOxCLR). These ports and registers are defined as scheme variables at the top of the code below. They are then used in functions that: 1) identify whether a given pin is set in a given gpio port; 2) set a given pin in a given gpio port, and; 3) clear a given pin in a gpio port. These basic functions are used in a 4th function that toggles a given pin on a given gpio port. Examples of its use to toggle LEDs on and off on various MCU boards are given.
; Armpit Scheme GPIO Example
; tested on Tiny2106
; define GPIO ports and offsets
(define gpio0 #xE0028000) ; IO0 port (PIN = #x00, SET = #x04, DIR = #x08, CLR = #x0C)
(define gpio1 #xE0028010) ; IO1 port (PIN = #x00, SET = #x04, DIR = #x08, CLR = #x0C)
(define pin-status #x00) ; IOxPIN register offset
(define pin-set #x04) ; IOxSET register offset
(define pin-clear #x0C) ; IOxCLR register offset
; function to check the status of a pin on a gpio port
(define (is-set? port pin)
(not (zero? (logand (read port pin-status) (ash 1 pin)))))
; function to set a pin on a gpio port
(define (set-pin port pin)
(write (ash 1 pin) port pin-set))
; function to clear a pin on a gpio port
(define (clear-pin port pin)
(write (ash 1 pin) port pin-clear))
; function to toggle a pin on a gpio port
(define (toggle port pin)
(if (is-set? port pin)
(clear-pin port pin)
(set-pin port pin)))
; toggle MCU board's LED(s)
(toggle gpio0 23) ; Tiny2106 red led
(toggle gpio0 24) ; Tiny2106 yellow led
(toggle gpio0 25) ; Tiny2106 green led
(toggle gpio1 21) ; Tiny213x red led
(toggle gpio1 22) ; Tiny213x yellow led
(toggle gpio1 23) ; Tiny213x green led
(toggle gpio1 24) ; LPC-H2148 green led
(toggle gpio0 30) ; LPC-H2214 red led
Armpit Scheme's extended read/write functions can be used to configure and control the MCU's PWM output lines. The example below demonstrates this application for the PWM2 line. The code starts by defining the PINSEL0 and PWM ports (base addresses of #xE002C000 and #xE0014000) that are needed to configure P0.7 as the PWM2 output line. The PWM block is then configured for a 2.5 ms period with 1024 ticks per period. This is performed by writing to the PWMPR, PWMMR0 and PWMMCR MCU registers that are at offsets of #x0C, #x18 and #x14 from the PWM port's base address. MCU pin P0.7 is then configured for operation as PWM2 using a read-modify-write process to PINSEL0 (at offset #x00) that maintains the configuration of other MCU pins and changes only P0.7. This is followed by startup of PWM2, in single-edged mode, with a duty cycle of zero, by writing to PWMMR2, PWMPCR and PWMLER (offsets of #x0C, #x4C and #x50 above pwm). The PWM initialization code is followed by the definition of a function, set-pwm, that sets the duty cycle of a PWM channel to a given value. The function is applied to modify the duty cycle of PWM2 from its initial value of zero to a value of 500.
; Armpit Scheme PWM Example
; tested on Tiny2138
; define useful ports
(define pinsel #xE002C000) ; PINSEL (0 = #x00, 1 = #x04, 2 = #x14)
(define pwm #xE0014000) ; PWM (TCR = #x04, PR = #x0C, MCR = #x14, MR0 = #x18, MR2 = #x20, PCR = #x4C, LER = #x50)
; configure PWM block
(begin
(write 145 pwm #x0C) ; set prescale count register to 145 = 411 kHz via PWMPR
(write 1023 pwm #x18) ; set PWM rate register to 1023 = 401 Hz (period = 2.5 ms) via PWMMR0
(write 2 pwm #x14)) ; set timer to reset at end of each cycle via PWMMCR
; configure PWM2 (P0.7)
(begin
(write (logior #x8000 (logand #xFFF3FFF (read pinsel #x00))) pinsel #x00) ; make P0.7 a PWM pin (i.e. PWM2) via PINSEL0
(write 0 pwm #x20) ; set PWM2 duty cycle to 0 via PWMMR2
(write #x0400 pwm #x4c) ; enable PWM2 single-edge output (bit 10, i.e. 2 + 8) via PWMPCR
(write #x04 pwm #x50)) ; Latch desired PWM2 rate for update (bit 2) via PWMLER
; function to set the PWM duty cycle to a given value (0 to 1023) on a given pwm channel
(define (set-pwm channel value)
(write value pwm (+ #x18 (ash channel 2))) ; set duty in Match register PWMMRx
(write (ash 1 channel) pwm #x50)) ; set channel bit in Latch PWMLER
; set duty-cycle of PWM2 (pin P0.7) to 500
(set-pwm 2 500)
Armpit Scheme can be used to read the MCU's ADC lines as examplified below for adc0 line 0 (pin P0.27). The pin is configured to ADC function via a read-modify-write operation to PINSEL1 (base address #xE002C000, register offset #x04). A function, read-adc, is defined to obtain values from a given channel of adc0 and it is then applied to reading a value from channel 0 of adc0 (i.e. from pin P0.27). The function set-adc initiates adc conversion by writing the startup code #x01201000 to adc0's register AD0CR (base address #xE0034000, offset #x00). It then waits in a tail-recursive loop for the conversion to be complete as indicated by the selected channel's bit in AD0STAT (offset #x30). When the data is ready, read-adc reads and extracts it from AD0DR (offset #x04), and returns the result.
; Armpit Scheme ADC Example
; tested on Tiny2138
; define useful ports
(define pinsel #xE002C000) ; PINSEL (0 = #x00, 1 = #x04, 2 = #x14)
(define adc #xE0034000) ; ADC0
; configure adc0.0 (P0.27)
(write (logior #x400000 (logand #xFF3FFFF (read pinsel #x04))) pinsel #x04) ; make P0.27 an ADC pin (i.e. ADC0.0) via PINSEL1
; function to read a value from an input channel in adc0
(define (read-adc channel)
(write (logior #x01201000 (ash 1 channel)) adc #x00) ; start 10-bit conversion on channel via AD0CR
(let loop ((status 0))
(if (zero? (logand status (ash 1 channel))) ; check if conversion is done
(loop (read adc #x30)) ; if not, loop with new status read from AD0STAT
(logand #x03FF (ash (read adc #x04) -6))))) ; if so, read and return value from AD0DR
; read a value from adc0 channel 0 (P0.27)
(read-adc 0)
Armpit Scheme allows the user to configure and use the MCU's UART1. The program below examplifies configuration and use of UART1 to write to a Serial LCD module (the BPI-216 from Scott Edwards Electronics was used for testing). The uart is enabled and configured by writing to registers U1FCR, U1LCR, U1DLL and U1DLM (base address #xE0010000, offsets #x08, #x0C, #x00 and #x04). The corresponding MCU pin (P0.8) is then configured to operate as uart1's Tx line by writing to PINSEL0 (base address #xE002C000, offset 0). The scheme functions write-char and write are then used to write command characters and write the external representations of scheme objects, respecitvely, to the LCD, via the uart1 port.
; Armpit Scheme Example of Serial Communication to an LCD, via uart1
; tested on Tiny2138
; define useful ports
(define pinsel #xE002C000) ; PINSEL port (0 = #x00, 1 = #x04, 2 = #x14)
(define uart1 #xE0010000) ; UART1 port (RBR = THR = DLL = #x00, DLM = IER = #x04, LCR = #x0C, LSR = #x14)
; enable and configure UART1 for 9600,8,N,1 communication
(begin
(write #x01 uart1 #x08) ; enable UART1 via U1FCR
(write #x80 uart1 #x0C) ; enable Divisor Latch (DLAB = 1) via U1LCR
(write #x87 uart1 #x00) ; set low divisor for 9600 bauds via U1DLL
(write #x01 uart1 #x04) ; set high divisor for 9600 bauds via U1DLM
(write #x03 uart1 #x0C)) ; set 8 data bits, no parity, 1 stop bit via U1LCR
; Connect UART Tx pin
(write (logior #x010000 (logand #xFFFCFFFF (read pinsel #x00))) pinsel #x00)
; clear the LCD screen
(begin
(write-char (integer->char 254) uart1)
(write-char (integer->char 1) uart1))
; write-out a string
(write "hello: " uart1)
; move to line 2 of LCD
(begin
(write-char (integer->char 254) uart1)
(write-char (integer->char 192) uart1))
; write-out a number
(write (/ 100 -3) uart1)
Armpit Scheme supports multitasking by allowing its user to define a process-queue switched by the MCU's timer 0 or timer 1 interrupt callbacks. The code below examplifies. It starts by defining useful ports and register offsets, as well as timer management functions (stop, restart). It then configures timer 0 to operate with a one micro-second tick. An empty process queue is then defined and a function that switches tasks from this queue is installed as the timer 0 callback by writing it to timer 0 port, offset #x010000. The timer is then configured to generate interrupts every 10 ms and is started. Two utility functions are then defined: spawn and toggler. The first is used to spawn a thunk onto the process queue and the other produces a thunk that toggles a GPIO pin every time its internal counter reaches zero. The toggler uses the functions defined earlier in the GPIO example (above) which are therefore also needed for running this multitasking example. The last few lines of code show how to spawn LED togglers on selected LPC2000 boards.
; Armpit MultiTasking Example
; Tested on Tiny2106 [requires the GPIO example, above]
; define useful ports and offsets
(define timer0 #xE0004000) ; T0 (IR = #x00, TCR = #x04, TC = #x08, PR = #x0C, MCR = #x14, MR0 = #x18)
(define timer-period #x18) ; TxMR0 offset
(define timer-count #x08) ; TxTC offset
; function to stop a timer
(define (stop timer)
(write 0 timer #x04)) ; disable timer via TxTCR
; function to restart a timer
(define (restart timer)
(write 2 timer #x04) ; reset timer via TxTCR
(write 1 timer #x04)) ; enable and start timer via TxTCR
; configure timer0
(begin
(write 59 timer0 #x0C) ; set timer0 period to 1 us (for 60MHz clk) via T0PR
(write 5 timer0 #x14)) ; set timer0 to generate interrupt and stop on MR0 match via T0MCR
; Initialize the process queue
(define *queue* '())
; Set timer 0 callback to switch queued thunks
(write
(lambda ()
(call/cc
(lambda (resume)
(restart timer0)
(if (null? *queue*)
(resume #t)
((car *queue*) (set! *queue* (append (cdr *queue*) (list resume))))))))
timer0 #x010000)
; Start timer 0 to produce interrupts every 10 ms for task switching
(begin
(stop timer0)
(write 10000 timer0 timer-period)
(restart timer0))
; read the timer count (to check proper operation, read it a few times)
(read timer0 timer-count)
; function to spawn a new thunk (task)
(define (spawn thunk)
(stop timer0)
(set! *queue*
(cons
(lambda ()
(thunk)
((car *queue*) (set! *queue* (cdr *queue*))))
*queue*))
(restart timer0))
; function to toggle a gpio pin every "ticks" countdown ticks
(define (toggler port pin ticks)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(begin
(toggle port pin)
(go ticks))))))
; spawn toggler on MCU board's LED(s)
(spawn (toggler gpio0 23 200)) ; Tiny2106 red led
(spawn (toggler gpio0 24 100)) ; Tiny2106 yellow led
(spawn (toggler gpio0 25 50)) ; Tiny2106 green led
(spawn (toggler gpio1 21 200)) ; Tiny213x red led
(spawn (toggler gpio1 22 100)) ; Tiny213x yellow led
(spawn (toggler gpio1 23 50)) ; Tiny213x green led
(spawn (toggler gpio1 24 200)) ; LPC-H2148 green led
(spawn (toggler gpio0 30 200)) ; LPC-H2214 red led
Armpit Scheme allows acces to the MCU's TIMER1 functions which can be used, for example, to drive the SRF-04 Ultrasonic Range Finder from Devantech (eg. sensors section at Acroname). In this application, a Match pin and Match register are used to control the Trigger Input line of the Ranger, and a Capture pin and Capture register are used to latch the round-trip echo time from the Echo Out line of the Ranger. As with the previous examples, TIMER1 registers are accessed using Armpit Scheme's extended read/write functions with both the port (#XE0008000) and register offsets specified. The program below examplifies the configuration of TIMER1 and its use for this application.
; Armpit Scheme Ultrasonic Ranger Example
; tested on Tiny2106
; define useful ports
(define timer1 #XE0008000) ; T1 (IR = #x00, TCR = #x04, TC = #x08, PR = #x0C, MCR = #x14, MR0 = #x18)
(define pinsel #xE002C000) ; PINSEL (0 = #x00, 1 = #x04, 2 = #x14)
; Configure match and capture pins (P0.17 <- match 1.2, P0.19 <- capture 1.2)
(write (logior #xCC (logand #xFFFFFF33 (read pinsel #x04))) pinsel #x04) ; set P0.19, P0.17 to CAP1.2, MAT1.2 (bits 7:6 & 3:2)
; configure timer1
(begin
(write 59 timer1 #x0C) ; set Prescale Register for 1 micro-secs timing (at 60MHZ) via T1PR
(write #x00 timer1 #x70) ; set timer1 to timer mode via T1CTCR
(write #x04 timer1 #x14) ; set timer1 to stop timer on MR0 and do nothing on MR2 via T1MCR
(write 50000 timer1 #x18) ; set timer1 to stop after 50 milli-secs (if no echo) via T1MR0
(write 100 timer1 #x20) ; set 100 micro-secs sonar control pulse on MAT1.2 via T1MR2
(write #x80 timer1 #x28)) ; set CAP1.2 to capture timer value on falling edge of P0.19 via T1CCR
; function to get sonar reading as round-trip echo time in micro-seconds
(define (read-sonar)
(write #x02 timer1 #x04) ; reset and stop TIMER1 via T1TCR
(write #x0104 timer1 #x3C) ; set timer1 to make P0.17 high first, then low on MR2 match via T1EMR
(write #x01 timer1 #x04) ; start TIMER1 via T1TCR
(let loop ((status 1))
(if (zero? (logand #x01 status)) ; is timer stopped?
(read timer1 #x34) ; if so, read echo time in micro-seconds + 100 from T1CR2
(loop (read timer1 #x04))))) ; if not, loop with status update from T1CR
; function to get sonar reading and return it as a distance in centimeters
(define (sonar-cm)
(/ (- (read-sonar) 100) 2 29.033))
; read the sonar
(sonar-cm)
The MCU's Real-Time Clock (RTC) is accessible to Armpit Scheme via the extended read/write functions. The RTC port's base address is #xE0024000 and several registers are used to configure the peripheral and read/write time-date values from/to it. The example below illustrates how to configure the RTC and how the hour, minute, seconds, year, month and day-of-month registers are accessed.
; Armpit Real-Time Clock Example (see also NXP/Philips AN10382)
; tested on Tiny2106
; define useful port and offsets
(define rtc #xE0024000) ; RTC (ILR = #x00, CCR = #x08, PREINT = #x80, PREFRAC = #x84)
(define year #x3C)
(define month #x38)
(define dom #x2C)
(define hour #x28)
(define minute #x24)
(define second #x20)
; configure the RTC
(begin
(write 2 rtc #x08) ;
(write 3 rtc #x00) ; clear any pending clock interrupt via ILR
(write 1830 rtc #x80) ;
(write 1792 rtc #x84) ;
(write 1 rtc #x08)) ;
; function to read/set the date
(define date
(lambda opt-date-list
(if (null? opt-date-list)
(list (read rtc month) (read rtc dom) (read rtc year))
(begin
(write (car opt-date-list) rtc month)
(write (cadr opt-date-list) rtc dom)
(write (caddr opt-date-list) rtc year)))))
; function to read/set the time
(define time
(lambda opt-time-list
(if (null? opt-time-list)
(list (read rtc hour) (read rtc minute) (read rtc second))
(begin
(write (car opt-time-list) rtc hour)
(write (cadr opt-time-list) rtc minute)
(write (caddr opt-time-list) rtc second)))))
; reading the date
(date)
; setting the date to July 16, 2006
(date 7 16 2006)
; reading the time
(time)
; setting the time to 4:10:00am
(time 4 10 0)
Armpit Scheme allows I2C communication as master and slave (on the LPC2000). The default MCU address is 100 and can be modified. I2C communication typically requires at least two devices (one master, one slave) and is examplified in the two code examples below. Each example consists of two programs: one for the Slave device and one for the Master device.
The first example illustrates how a Slave device can echo the data it receives from the Master, back to the Master device. The code for the Slave device in this example first configures and enables the I2C0 peripheral block and then sets the Slave device's address to 20 using the statement: (write 40 i2c #x0C) in which 40 represents twice the desired address. An infinite loop (labeled echo) is then entered that continuously reads the I2C channel (read as slave) and echoes what is read back into the I2C buffer (write as slave) where it can be read by the Master device.
The Slave device program is best stored into the MCU's FLASH as a scheme startup program by using Armpit Scheme's (flash) command. As illustrated below, a startup program should not have comment statements and each scheme expression in it should be separated by a blank line. Entry of the Startup program is ended by pressing ctrl-d to save it to FLASH or ctrl-c to cancel. Recovey of an MCU whose Startup program is an infinite loop, if needed, is performed by tying P0.3 to ground at reset, which bypasses execution of the Startup, and then using (flash) to store and empty program in FLASH (i.e. press ctrl-d directly after (flash)).
The Master device code for example 1 starts with configuration and enabling of the I2C channel. Once this is done, and the Master and Slave have been appropriately connected to one another by a pair of wires + ground, the MCU is ready to write and read data to and from the Slave device. The Slave device sends the eof-object when its output buffer is empty and this can be identified using the eof-object? scheme function. The Master in the example code communicates with the Slave device whose ID is 20. The target MCU is specified in Armpit Scheme's extended read/write functions by a vector whose first item is the device ID: 20. This vector is used as the optional {register} argument and the {port} argument is the base address of the I2C block in the MCU (#xE001C000).
; Armpit Scheme I2C Communication Example 1: Code for Echo by the Slave Device (flashed as scheme startup program)
; Tested on Tiny2138
(flash)
(define i2c #xE001C000)
(define pinsel #xE002C000)
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0)
(begin
(write 47 i2c #x10)
(write 103 i2c #x14)
(write #x28 i2c #x18)
(write #x44 i2c #x00))
(write 40 i2c #x0C)
(let echo ()
(write (read i2c) i2c)
(echo))
ctrl-d
; Armpit Scheme I2C Communication Example 1: Code for the Master Device
; Tested on Tiny2106
; define useful ports
(define i2c #xE001C000) ; I2C0 port (CONSET = #x00, STAT = #x04, SCLH = #x10, SCLL = #x14, CONCLR = #x18)
(define pinsel #xE002C000) ; PINSEL0 port (0 = #x00, 1 = #x04, 2 = #x14)
; configure MCU pins for I2C0 operation
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0) ; configure P0.2 and P0.3 as I2C via PINSEL0
; initialize the I2C0 peripheral
(begin
(write 47 i2c #x10) ; set I2C high clock period to 0.783 us (60 MHz pclck, 400kb/s) via I2C0SCLH
(write 103 i2c #x14) ; set I2C low period to 1.716 us (60 MHz pclck, 400kb/s) via I2C0SCLL
(write #x28 i2c #x18) ; clear STA and SI via I2C0CONCLR
(write #x44 i2c #x00)) ; enable I2C on port 0, both master and slave (set I2EN, AA) via I2C0CONSET
; see if anything is available on the input port
(eof-object? (read i2c '#(20)))
; send an integer to the Slave device
(write 123 i2c '#(20))
; read the data back from the Slave device
(read i2c '#(20))
; send #t to the Slave device
(write #t i2c '#(20))
; read the data back from the Slave device
(read i2c '#(20))
; send a string to the Slave device
(write "hello" i2c '#(20))
; read the data back from the Slave device
(read i2c '#(20))
The second example illustrates how a Slave device can evaluate expressions it receives from the Master, and return the result back to the Master device. The code is very similar to that of example 1. The main difference is that objects to be evaluated are sent in packed form using the pack function of Armpit Scheme. The packed objects returned by this function are position independent deep copies of scheme objects, represented as byte vectors, in which address pointers have been replaced by offsets, pointing to locations within the vector, where packed copies of the objects originally pointed to are stored. They allow scheme lists, vectors and closures to be transmitted across communication channels.
Upon receipt by the Slave device, the packed object is unpacked (using Armpit Scheme's unpack function) and evaluated. The result of evaluation is then packed and sent back to the Master device. The Master device follows a similar approach when sending an object to be evaluated: it packs it and then writes it to the Slave device. The Master device then reads the packed result back from the Slave device and unpacks it to ascertain its value.
; Armpit Scheme I2C Communication Example 2: Code for Evaluation by the Slave Device (flashed as scheme startup program)
; Tested on Tiny2106
(flash)
(define i2c #xE001C000)
(define pinsel #xE002C000)
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0)
(begin
(write 47 i2c #x10)
(write 103 i2c #x14)
(write #x28 i2c #x18)
(write #x44 i2c #x00))
(write 40 i2c #x0C)
(let rep ()
(write (pack (eval (unpack (read i2c)))) i2c)
(rep))
ctrl-d
; Armpit Scheme I2C Communication Example 2: Code for the Master Device
; Tested on Tiny2138
; define useful ports
(define i2c #xE001C000) ; I2C0 port (CONSET = #x00, STAT = #x04, SCLH = #x10, SCLL = #x14, CONCLR = #x18)
(define pinsel #xE002C000) ; PINSEL0 port (0 = #x00, 1 = #x04, 2 = #x14)
; configure MCU pins for I2C0 operation
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0) ; configure P0.2 and P0.3 as I2C via PINSEL0
; initialize the I2C0 peripheral
(begin
(write 47 i2c #x10) ; set I2C high clock period to 0.783 us (60 MHz pclck, 400kb/s) via I2C0SCLH
(write 103 i2c #x14) ; set I2C low period to 1.716 us (60 MHz pclck, 400kb/s) via I2C0SCLL
(write #x28 i2c #x18) ; clear STA and SI via I2C0CONCLR
(write #x44 i2c #x00)) ; enable I2C on port 0, both master and slave (set I2EN, AA) via I2C0CONSET
; remotely sum a list of numbers
(write (pack '(+ 3 5 7 9 11 13 15)) i2c '#(20))
; get the result back from the Slave device
(unpack (read i2c '#(20)))
; closure to get mcu-id
(define (mcu-id) (ash (read i2c #x0C) -1))
; read remote mcu-id
(write (pack (list mcu-id)) i2c '#(20))
; get the result back from the Slave device
(unpack (read i2c '#(20)))
Armpit Scheme can be used to implement a rudimentary expert system. The main limitation in this sort of exercise is the amount of RAM available to the MCU. The example below runs fine with 64KB of RAM but is certainly slower than one may like (or need for real-time control applications). It uses a form of McCarthy's nondeterministic AMB (ambiguous) operator.
; 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 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 identify whether a variable is bound
(define (bound? var)
(or (defined? var)
(eval `(define ,var 'UNASSIGNED)))
(not (eq? (eval var) 'UNASSIGNED)))
; 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 '(?x jim ?y))
(all '(grandparent ?x ?x))
(all '(son ?x ?y))
(all '(son jim ?x))
(all '(son ?x jim))
(all '(daughter ?x joe))
Armpit Scheme is being tested for its ability to run the declarative logic programming system miniKANREN. At the time of this writing, it has been identified that the treatment of ellipsis in Armpit Scheme's macro system is not as powerful as described in r5rs and hence two modifications (minimum) are required to get miniKANREN running on Armpit (up to test #4.57). The required modifications to the "fresh" and "conde" macros are given below.
; Armpit Example Modifications to miniKANREN
; Tested on Tiny2106
; modification of the fresh macro
(define-syntax fresh
(syntax-rules ()
((_ (x ...) g ...)
(lambdag@ (s)
(fresh+ (x ...) (g ...) s)))))
; helper macro for fresh
(define-syntax fresh+
(syntax-rules ()
((_ (x) (g ...) s)
(let ((x (var 'x)))
((all g ...) s)))
((_ (x y ...) (g ...) s)
(let ((x (var 'x)))
(fresh+ (y ...) (g ...) s)))))
; modification of the conde macro
(define-syntax conde
(syntax-rules (else)
((_) fail)
((_ (else g ...)) (all g ...))
((_ (g ...) c ...)
(anye (all g ...) (conde c ...)))))
As a last example, Armpit Scheme can be used to apply the obfuscating Applicative Order Y-combinator described for example by Daniel P. Friedman and Matthias Felleisen in The Little Schemer (I believe). It is applied below to calculating the factorial of 7 via anonymous recursion.
; Armpit Example of Applicative Order Y-combinator, for anonymous recursion
; tested on Tiny2106
; the Y-combinator:
(define Y
(lambda (g)
((lambda (f) (f f))
(lambda (f) (g (lambda (x) ((f f) x)))))))
; its application to calculating 7! :
((Y (lambda (f) (lambda (n) (if (< n 2) 1 (* n (f (- n 1)))))))
7)