A collection of short programs and program fragments I've previously published on pastebins. Your mileage may vary.
K-Means Clustering in K. (May 14th, 2020)
/ the infamous iris dataset, truncated for brevity
cols:`sepalLength`sepalWidth`petalLength`petalWidth`species
iris:((5.1; 3.5; 1.4; 0.2; `setosa)
(4.9; 3.0; 1.4; 0.2; `setosa)
(4.7; 3.2; 1.3; 0.2; `setosa)
(7.0; 3.2; 4.7; 1.4; `versicolor)
(6.4; 3.2; 4.5; 1.5; `versicolor)
(6.3; 3.3; 6.0; 2.5; `virginica)
(5.8; 2.7; 5.1; 1.9; `virginica))
/ preamble:
iris: cols!+iris
scale:{a:&/x;b:|/x;w*(x-a)%b-a}
scatter:{{(_x;pico 8 11 9;2 2#y)}'[x;y]} / (data;class)
/ stage 1: raw data
data:+scale'iris`sepalWidth`petalLength
input:scatter[data;(?iris`species)?iris`species]
/ stage 2: pick centroids
k:3
c:(-k)?data
input,,(_c;;4 4#1)
/ stage 3: show classified by centroid
membership:{(*<:)'x{%+/t*t:x-y}/:\:y}
draw: {scatter[data;membership[data;c]],,(_c;;4 4#1)}
/ stage 4: refine centroids
clusteraverage: {{(+/x)%#x}'x@.=y}
c:clusteraverage[data]@membership[data;c]
Setup script for the OLPC's default Fedora Linux image. (Fed 5th, 2020)
#!/bin/bash # OLPC setup script # First, make sure your OS is updated to the latest version: # http://wiki.laptop.org/go/Release_notes/13.2.11#Installation # Then ensure you have a WiFi connection. # fix clock (modify time zone as desired) sudo ntpdate pool.ntp.org sudo hwclock --systohc sudo unlink /etc/localtime sudo ln -s /usr/share/zoneinfo/US/Eastern /etc/localtime # adjust to taste # re-enable man pages; they are not installed by default sudo bash -c 'sed "/excludedocs/d" /etc/rpm/macros.imgcreate > /etc/rpm/macros.imgcreate' # add functioning package repositories sudo yum install -y --nogpgcheck http://download1.rpmfusion.org/free/fedora/rpmfusion-free-release-$(rpm -E %fedora).noarch.rpm sudo yum install -y --nogpgcheck http://download1.rpmfusion.org/nonfree/fedora/rpmfusion-nonfree-release-$(rpm -E %fedora).noarch.rpm # install development tools and nice-to-haves sudo yum install -y man man-pages libstdc++-docs gcc-c++ libX11-devel make git vim mplayer rlwrap nc tree php # and now some personal preferences: # configure git git config --global color.ui auto git config --global core.editor "vim" git config --global push.default simple # git config --global user.name "name" # git config --global user.email name@example.com # configure .vimrc echo -e "set shiftwidth=2\nset tabstop=2\n" > ~/.vimrc # configure .bashrc # echo "" >> ~/.bashrc # echo "export PATH=/usr/local/bin/k3:$PATH" >> ~/.bashrc # echo "export PATH=/usr/local/bin/qjs:$PATH" >> ~/.bashrc # echo "alias js='qjs32'" >> ~/.bashrc # sudo mkdir /usr/local/bin/k3 # sudo mkdir /usr/local/bin/qjs
A Lisp(ish) S-Expression parser in ES6, supporting symbols, signed ints, lists, and line comments. (Dec 13th, 2019)
const token = /^\s*(?:;[^\n]*\n)*\s*(?:(-?\d+)|([a-z\-!?]+|[+\-*\/<>=()]))/
function parse(text) {
const term = _ => {
const x = token.exec(text)
if (!x) throw 'Reached the end of input while parsing!'
text = text.slice(x[0].length)
const here = x[1] ? +x[1] : x[2]
if (here != '(') return here
let ret = [], next
while (')' != (next = term())) ret.push(next)
return ret
}
return term()
}
// tests
function test(x, y) {
const a = JSON.stringify(x), b = JSON.stringify(y)
if (a != b) console.log(`got: ${a}\nexpected: ${b}`)
}
test(parse('(first (list 1 (+ 2 3) 9))'), ['first',['list',1,['+',2,3],9]])
test(parse('(-234 ; comment\ndashed-atom!)'), [-234,'dashed-atom!'])
test(parse('(3 (4 (5 6)) (7 8))'), [3,[4,[5,6]],[7,8]])
test(parse('bare-atom?'), 'bare-atom?')
Encode and decode a useful subset of the "A1" cell-index format Excel uses by default. (Sep 24, 2019)
const ALPHABET = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
function parseA1(x) {
x = x.toUpperCase().replace(/\$/g, '') // we don't care about global vs. relative coords
const c = (x.match(/[A-Z]+/)||['A'])[0]
const r = +(x.match(/[0-9]+/)||['1'])[0]
let cn = 0
c.split('').forEach(x => { cn*=26; cn+=1+ALPHABET.indexOf(x) })
return [cn,r]
}
function formatA1(x) {
let c='', n=x[0]
while(n>0) { c=ALPHABET[n%26-1]+c; n=0|n/26 }
return c+x[1]
}
// tests
const a = ['A1', 'TB1', 'AA1', 'AB1', 'ACA1']
const b = [[1,1],[522,1],[27,1],[28,1],[755,1]]
const v1 = a.map(parseA1)
const v2 = b.map(formatA1)
if (JSON.stringify(b)!=JSON.stringify(v1)) console.log('parsing tests failed')
if (JSON.stringify(a)!=JSON.stringify(v2)) console.log('formatting tests failed')
A compact set of PEG parser combinators in ES6. (Mar 30, 2017)
const lookup = x => typeof x == 'string' ? eval(x) : x
const match = (x, y, z) => x ? { c:y, v:z } : { e: true }
const eof = s => match(s.length, 0, '')
const char = s => match(s.length, 1, s[0])
const not = g => s => match(g(s).e, 0, '')
const has = g => s => match(!g(s).e, 0, '')
const oneof = t => s => match(t.indexOf(s[0]) >= 0, 1, s[0])
const lit = t => s => match(!s.indexOf(t), t.length, t)
const option = g => choose(g, lit(''))
const prod = (g, f) => s => (r => r.e ? r : { c:r.c, v:f(r.v) })(g(s))
const choose = (...a) => s => a.reduce((x, y) => x.e ? y(s) : x, { e: true })
const seq = (...a) => s => a.reduce(function(x, y) {
var r = x.e ? x : lookup(y)(s.slice(x.c))
return r.e ? r : { c:x.c+r.c, v:x.v.concat([r.v]) }
}, { c:0, v:[] })
// usage example:
const noun = oneof('abcdefghijklmnopqrstuvwxyz')
const xcolon = x => prod(seq(oneof(x), option(lit(':'))), x => x.join(''))
const verb = xcolon('+-*%!&|<>=~,^#_$?@.')
const adverb = xcolon('\'\\/')
const term = choose(prod(seq(lit('('), 'kexpr', lit(')')), x => x[1]), noun)
const kexpr = choose(
prod(seq(term, adverb, 'kexpr'), x => [x[1], x[0], x[2]]),
prod(seq(term, verb, 'kexpr'), x => [x[1], x[0], x[2]]),
seq(adverb, 'kexpr'),
seq(verb, 'kexpr'),
term
)
const test = x => console.log(JSON.stringify(x.v))
test(kexpr('+b'))
test(kexpr('a+b'))
test(kexpr('(a+b)*c'))
test(kexpr('a+b*c'))
test(kexpr('f/b+c'))
test(kexpr('a+f/b+c'))
test(kexpr('(a+f)/b+c'))
test(kexpr('a+f/*:\'z-w'))
Convert video files into a format that is playable on a Playstation 3. (Nov 25, 2014)
#!/bin/bash ffmpeg -y -i "$1" -vcodec libx264 -level 41 -crf 24 -threads 0 -acodec aac -ab 128k -ac 2 -ar 48000 -strict -2 "$1".mp4
A text adventure game framework written in Loko-compatible Logo. This is a pretty good demo of "leaning into" Logo's dynamically-scoped nature. (Dec 21, 2013)
to command local 'x readlist unless word? first :x [pr [?] output command] output first :x end to select :verb :ops :default if empty? :ops [default :verb stop] if equal? first :ops :verb [run first butfirst :ops stop] select :verb butfirst butfirst :ops :default end to balk :verb pr [I do not understand.] end to choose :ops select command :ops :balk end to play room play end to northroom pr [The north room... exit south.] choose [ s [make 'room :startroom] ] end to eastroom pr [The east room... exit west.] choose [ w [make 'room :startroom] ] end to startroom pr [You are in a small room.] pr [Exits lead north and east.] choose [ n [make 'room :northroom] e [make 'room :eastroom ] ] end to adventure local 'room :startroom pr [Welcome to the Adventure!] play end
A very simple ELIZA-style psychotherapist program written in Loko-compatible Logo. (Dec 8, 2013)
to any :list
output item random size :list :list
end
to idle
output any [
[Go on, go on.]
[What does that suggest to you?]
[How does that make you feel?]
]
end
to response :text :pairs
if empty? :pairs [output idle]
unless empty?
member first first :pairs :text [
output butfirst first :pairs
]
output response :text butfirst :pairs
end
to converse
pr response readlist [
[because Is that the real reason?]
[yes You seem quite positive.]
[not Why not? ]
]
converse
end
to eliza
pr [Hi, I'm Eliza. What seems to be the problem?]
converse
end
A FlashForth program for the PICDEM Explorer board which interfaces with the LCD Module. (Jun 11, 2013)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ LCD Driver \ \ This project uses FlashForth to write text \ to the LCD display on the Microchip PICDEM \ PIC18 Explorer Demo Board, running on a \ PIC18F8722 microcontroller. \ \ John Earnest \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ marker -lcd-driver \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ First we'll define some words to configure \ MSSP1 for SPI and write data through it: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ $ff94 con trisc $ffc6 con ssp1con1 $ffc7 con ssp1stat $ffc9 con ssp1buf $ff9e con pir1 : spi-init ( -- ) %00101000 trisc mclr \ make sdo and sck output %00100010 ssp1con1 c! \ enable ssp %01000000 ssp1stat mset \ configure clock select ; : spi-write ( 8b -- ) %1000 pir1 mclr \ clear transmit flag ssp1buf c! \ write data begin \ wait for transmit %1000 pir1 mtst until ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Using our previously defined SPI communication \ vocabulary, define some words for writing \ to the ports of an MCP23S17 port expander: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ $ff92 con trisa $ff89 con lata : cs-up %100 lata mset ; ( -- ) : cs-dn %100 lata mclr ; ( -- ) : mcp-write ( 8b reg -- ) cs-dn %01000000 spi-write \ write control spi-write \ write register spi-write \ write value cs-up ; : mcp-init ( -- ) spi-init %100 trisa mclr \ make ra2 output 0 0 mcp-write \ init port a 0 1 mcp-write \ init port b cs-up ; : mcp-a $12 mcp-write ; ( 8b -- ) : mcp-b $13 mcp-write ; ( 8b -- ) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Now that we can talk to the HD44780 \ display driver, define a vocabulary for \ interacting with it: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : lcd-i ( op -- ) $00 mcp-a mcp-b $40 mcp-a \ clock $00 mcp-a ; : lcd-emit ( char -- ) $80 mcp-a \ register select mcp-b $c0 mcp-a \ clock, register select $00 mcp-a ; : lcd-init ( -- ) mcp-init $3c lcd-i \ 0011NFxx $0c lcd-i \ display off $01 lcd-i \ display clear $06 lcd-i \ entry mode ; : lcd-line1 $80 lcd-i ; : lcd-line2 $c0 lcd-i ; : lcd-clear $01 lcd-i ; : lcd-type for dup @ lcd-emit 1+ next drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Finally, a simple test application: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : hello ( -- ) lcd-init lcd-line1 s" Hello," lcd-type lcd-line2 s" World!" lcd-type ;
A compact, simple implementation of a garbage-collected cons-pair heap utilizing Cheney's algorithm. (Jan 12, 2013)
\ \ Garbage.fs \ \ A compact, simple implementation of a garbage-collected \ cons-pair heap utilizing Cheney's algorithm. \ Pointers to pairs are identified by a pattern in the \ high-order bits of a value, chosen not to collide \ with the constants "true" or "false". \ $60000000 $40000000 cell 8 = [if] 32 lshift swap 32 lshift swap [then] constant pair-flag constant pair-mask pair-mask invert constant pair-bits : pair? pair-mask and pair-flag = ; ( n -- flag ) : pair> pair-bits and ; ( pair -- addr ) : >pair pair-flag or ; ( addr -- pair ) : first pair> @ ; ( pair -- first ) : rest pair> cell + @ ; ( pair -- rest ) : first! pair> ! ; ( value pair -- ) : rest! pair> cell + ! ; ( value pair -- ) : split dup first swap rest ; ( pair -- first rest ) : -split dup rest swap first ; ( pair -- rest first ) 4096 cells constant heap-size create heap1 heap-size allot create heap2 heap-size allot variable head heap1 head ! variable from heap1 from ! variable to heap2 to ! : init-pair ( first rest -- pair ) head @ dup >r 2! 2 cells head +! r> >pair ; : gc-copy ( pair -- ) pair> dup from @ head @ within if dup dup 2@ init-pair swap ! then drop ; : follow ( addr -- ) dup @ pair? if dup @ gc-copy dup @ pair> @ over ! then drop ; : gc-scan do i follow cell +loop ; ( max min -- ) : gc ( -- ) to @ head ! sp0 @ sp@ gc-scan rp0 @ rp@ gc-scan to @ begin dup head @ < while dup follow cell + repeat drop from @ to @ from ! to ! ; : enough? head @ from @ heap-size + <= ; ( -- flag ) : pair ( first rest -- pair ) enough? if init-pair exit then gc enough? if init-pair exit then abort" Heap exhausted!" ;