Commit 0949acc29eb120814a5df395696e67a2e9265beb - Decoy

Initial import of files for Decoy. Work in progress! Chris Pressey 1 year, 8 months ago

5 changed file(s) with 835 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+33

-0

README.md less more

	0	Decoy
	1	=====
	2
	3	It's a simple functional language with a syntax markedly inspired by Scheme and
	4	semantics markedly inspired by Scheme.
	5
	6	But it's not Scheme. Thus the name.
	7
	8	It is also very much a work in progress.
	9
	10	Grammar
	11	-------
	12
	13	This is how the parser understands the program text:
	14
	15	```
	16	Expr ::= "(" Form ")"
	17	\| Symbol
	18	\| StrLit
	19	\| NumLit
	20	.
	21	```
	22
	23	On another level, we don't actually parse these, but we do interpret them:
	24
	25	```
	26	Form ::= "let*" Expr Expr
	27	\| "define" Symbol Expr
	28	\| "lambda" Expr Expr
	29	\| "cond" {Expr}
	30	\| "if" Expr Expr Expr
	31	\| {Expr}
	32	```

+283

-0

eg/cosmos-boulders.scm less more

	0	; Cosmos Boulders -- semantics of a video game given by pure functions ("reducers").
	1
	2	(define new-map (lambda ()
	3	(list)
	4	))
	5
	6	(define set (lambda (key val map)
	7	(cons (cons key val) map)
	8	))
	9
	10	(define get (lambda (key map)
	11	(cond
	12	((null? map) (error "No such key"))
	13	((equal? (car (car map)) key) (cdr (car map)))
	14	(else (get key (cdr map))))
	15	))
	16
	17	(define update (lambda (key fn map)
	18	(set key (fn (get key map)) map)))
	19
	20
	21	; --[ Player objects ]--------------------------------------------------------
	22
	23
	24	(define reset-player (lambda (player)
	25	(set "x" 200 (set "y" 200 (set "vx" 0 (set "vy" 0 (set "ax" 0 (set "ay" 0
	26	(set "h" 270 (set "dh" 0 (set "f" 0 (set "mode" "GET_READY" (set "timer" 200 player)))))))))))
	27	))
	28
	29	(define make-player (lambda ()
	30	(reset-player (set "score" 0 (set "lives" 2 (set "mass" 1 (new-map)))))
	31	))
	32
	33	; Reducer that takes a Player and an Action and returns a new Player.
	34	; Action must be one of: STEP \| SCORE_POINTS \| EXPLODE \| CONTROLS_CHANGED
	35	(define update-player (lambda (player action)
	36	(let* ((action-type (get "type" action)))
	37	(cond
	38	((equal? action-type "STEP")
	39	(cond
	40	((equal? (get "mode" player) "GET_READY")
	41	(count-down-to-mode player "PLAYING"))
	42	((equal? (get "mode" player) "PLAYING")
	43	(let*
	44	((player2 (set "h" (+ (get "h" player) (get "dh" player))
	45	(set "vy" (+ (get "vy" player) (get "ay" player))
	46	(set "vx" (+ (get "vx" player) (get "ax" player))
	47	(update-position player))))))
	48	(if (> (get "f" player) 0)
	49	; thrusters on!
	50	(let* ((theta (degrees-to-radians (get "h" player)))
	51	(fx (* f (math-cos theta)))
	52	(fx (* f (sin theta)))
	53	(m (get "mass" player)))
	54	(set "ax" (* fx m) (set "ay" (* fy m) player2))) ; // F=ma, so a = F/m
	55	; else no force, thus, no acceleration.
	56	(set "ax" 0 (set "ay" 0 player2)))))
	57	((equal? (get "mode" player) "EXPLODING")
	58	(count-down player (lambda (player)
	59	(if (gt? (get "lives" player) 0)
	60	(reset-player (update-with "lives" (lambda (x) (- x 1)) player))
	61	(set "mode" "GONE" player)))))))
	62	((equal? action-type "SCORE_POINTS")
	63	(update "score" (lambda (x) (+ x 10)) player))
	64	((equal? action-type "EXPLODE")
	65	(set "mode" "EXPLODING" (set "timer" 50 player)))
	66	((equal? action-type "CONTROLS_CHANGED")
	67	(cond
	68	((equal? (get "mode" player) "PLAYING")
	69	(let* ( (new-dh (if (get "leftPressed" action) -5 (if (get "rightPressed" action) 5 0)))
	70	(new-f (if (get "thrustPressed" action) 0.05 0.0)) )
	71	(set "f" new-f (set "dh" new-dh player))))
	72	((and (equal? (get "mode" player) "GET_READY") (fire-went-up action))
	73	(set "dh" 0 (set "f" 0 (set "mode" "PLAYING" player))))
	74	(else
	75	(set "dh" 0 (set "f" 0 player)))))
	76	(else
	77	(error "Unimplemented action")))
	78	)
	79	))
	80
	81
	82	; --[ Missile objects ]--------------------------------------------------------
	83
	84
	85	(define make-missile (lambda (x y vx vy)
	86	(set "x" x (set "y" y (set "vx" vx (set "vy" vy (set "mode" "MOVING" (set "timer" 50 (new-map)))))))
	87	))
	88
	89	; Reducer that takes a Missile and an Action and returns a new Missile.
	90	; Action must be one of: STEP \| EXPLODE
	91	(define update-missile (lambda (missile action)
	92	(cond
	93	((equal? action-type "STEP")
	94	(if (equal? (get missile "mode") "MOVING")
	95	(count-down-to-mode (update-position missile) "GONE")
	96	missile))
	97	((equal? action-type "EXPLODE")
	98	(if (equal? (get missile "mode") "MOVING")
	99	(set "mode" "GONE" (set "timer" 50 missile))
	100	missile))
	101	(else
	102	(error "Unimplemented action")))
	103	))
	104
	105
	106	; --[ Boulder objects ]--------------------------------------------------------
	107
	108
	109	(define make-boulder (lambda (i)
	110	(set "x" (math.floor (* (math.random) SCREEN_WIDTH))
	111	(set "y" (math.floor (* (math.random) SCREEN_HEIGHT))
	112	(set "vx" (- (math.random) 1.0)
	113	(set "vy" (- (math.random) 1.0)
	114	(set "mode" "APPEARING"
	115	(set "timer" 60 (new-map)))))))
	116	))
	117
	118	(define make-boulders (lambda ()
	119	(map (lambda (i) (make-boulder i)) (list 0 1 2 3 4 5 6 7))
	120	))
	121
	122	; Reducer that takes a Boulder and an Action and returns a new Boulder.
	123	; Action must be one of: STEP \| EXPLODE
	124	(define update-boulder (lambda (player action)
	125	(let* ((action-type (get "type" action)))
	126	(cond
	127	((equal? action-type "STEP")
	128	(cond
	129	((equal? (get "mode" boulder) "APPEARING")
	130	(count-down-to-mode boulder "MOVING"))
	131	((equal? (get "mode" boulder) "MOVING")
	132	(update-position boulder))
	133	((equal? (get "mode" boulder) "EXPLODING")
	134	(count-down-to-mode boulder "GONE"))
	135	(else
	136	boulder)))
	137	((equal? action-type "EXPLODE")
	138	(if (equal? (get "mode" boulder) "MOVING")
	139	(set "mode" "EXPLODING" (set "timer" 50 boulder))
	140	boulder))
	141	(else
	142	(error "Unimplemented action"))))
	143	))
	144
	145
	146	; --[ Game objects ]--------------------------------------------------------
	147
	148
	149	(define reset-game (lambda (game)
	150	(set "player" (make-player)
	151	(set "boulders" (make-boulders)
	152	(set "missiles" (make-missiles)
	153	(set "mode" "ATTRACT_TITLE" ; ATTRACT_TITLE \| ATTRACT_HISCORES \| GAME_ON \| GAME_OVER
	154	(set "timer" 400 game)))))
	155	))
	156
	157	(define make-game (lambda ()
	158	(reset-game
	159	(set "credits" 0
	160	(set "highscore" 0
	161	(set "timer" null
	162	(new-map)))))
	163	))
	164
	165	; Reducer that takes a Game and an Action and returns a new Game.
	166	; Action must be one of: FRAME_READY \| CONTROLS_CHANGED \| COIN_INSERTED
	167	(define update-game (lambda (game action)
	168	(let* ((action-type (get "type" action))
	169	(game-mode (get "mode" game)))
	170	(cond
	171	((equal? action-type "FRAME_READY")
	172	(cond
	173	((equal? game-mode "GAME_ON")
	174	(let* ((player (update-player (get "player" game) (set "type" "STEP" (new-map))))
	175	(boulders (map (lambda (b) (update-boulder b (set "type" "STEP" (new-map)))) (get "boulders" game)))
	176	(missile-reducer (lambda (accum missile)
	177	(let* ((missile (update-missile missile (set "type" "STEP" (new-map)))))
	178	(if (equal? (get "mode" missile) "GONE") accum (cons missile accum)))))
	179	(missiles (fold missile-reducer (new-list) (get "missiles" game)))
	180	(collision-result (detect-collisions player missiles boulders))
	181	(player (nth 0 collision-result))
	182	(missiles (nth 1 collision-result))
	183	(boulders (nth 2 collision-result))
	184	(boulders (if (equal? (len boulders) 0) (make-boulders) boulders))
	185	(new-highscore (if (> (get player "score") (get game "highscore")) (get player "score") (get game "highscore")))
	186	; Assemble new game state from all that
	187	(game (if (equal? (get player "mode") "GONE") (set "mode" "GAME_OVER" (set "timer" 100 (set "highscore" new-highscore game))) game))
	188	(game (set "player" player (set "boulders" boulders (set "missiles" missiles game))))
	189	)
	190	game))
	191	((equal? game-mode "GAME_OVER")
	192	(let* ((game (update "timer" (lambda (x) (- x 1)) game)))
	193	(if (equal? (get "timer" game) 0) (reset-game game) game)))
	194	((equal? game-mode "ATTRACT_TITLE")
	195	(if (> (get "credits" game) 0)
	196	game
	197	(count-down game (lambda (game)
	198	(set "mode" "ATTRACT_HISCORES" (set "timer" 400 game))))))
	199	((equal? game-mode "ATTRACT_HISCORES")
	200	(count-down game (lambda (game)
	201	(set "mode" "ATTRACT_TITLE" (set "timer" 400 game)))))
	202	(else
	203	(error "bad game mode" game-mode))))
	204	((equal? action-type "CONTROLS_CHANGED")
	205	(cond
	206	((or (equal? game-mode "ATTRACT_TITLE") (equal? game-mode "ATTRACT_HISCORES"))
	207	(let* ((start-pressed (get "startPressed" action))
	208	(prev-start-pressed (get "startPressed" (get "prev" action))))
	209	(if (and prev-start-pressed (not start-pressed))
	210	(if (> (get "credits" game) 0)
	211	(set "player" (reset-player (get "player" game))
	212	(update "credits" (lambda (x) (- x 1))
	213	(set "mode" "GAME_ON" game)))
	214	game)
	215	game)))
	216	((equal? game-mode "GAME_ON")
	217	(let* ((player (get "player" game)))
	218	(if (and (fire-went-down action) (equal? (get "mode" player) "PLAYING"))
	219	(let* ((mx (get "x" player))
	220	(my (get "y" player))
	221	(h (get "h" player))
	222	(mv 2.0)
	223	(mvx (* mv (math.cos (degrees-to-radians h))))
	224	(mvy (* mv (math.sin (degrees-to-radians h)))))
	225	(update "missiles" (lambda (missiles)
	226	(cons (make-missile mx my mvx mvy) missiles)) game))
	227	(set "player" (update-player (get "player" game) action) game))))
	228	((equal? game-mode "GAME_OVER")
	229	game)
	230	(else
	231	(error "bad game mode" game-mode))))
	232	((equal? action-type "COIN_INSERTED")
	233	(let* ((game (update "credits" (lambda (x) (+ x 1)) game)))
	234	(if (equal? game-mode "ATTRACT_HISCORES") (set "mode" "ATTRACT_TITLE" game) game)))
	235	(else
	236	(error "Unimplemented game action" action-type))))
	237	))
	238
	239
	240	; // Extracted from updateGame to avoid gigantic sprawling functions.
	241	; // Returns an array of 3 items: new Player, new List of Missiles, new List of Boulders.
	242	(define detect-collisions (lambda (player missiles boulders)
	243	(fold boulder-collision-check (list player missiles (list)) boulders)
	244	))
	245
	246	(define boulder-collision-check (lambda (boulder acc)
	247	(let* ((boulder-mode (get "mode" boulder)))
	248	(cond
	249	((equal? boulder-mode "GONE")
	250	acc)
	251	((equal? boulder-mode "MOVING")
	252	(let* ((player (nth 0 acc))
	253	(missiles (nth 1 acc))
	254	(boulders (nth 2 acc)))
	255	; 1. Check collision with player
	256	(if (and (equal? (get player "mode") "PLAYING")
	257	(< (math.abs (- (get player "x") (get boulder "x"))) 10)
	258	(< (math.abs (- (+ (get player "y") 5) (get boulder "y"))) 10))
	259	(list
	260	(update-player player (set "type" "EXPLODE" (new-map)))
	261	missiles
	262	(cons (update-boulder boulder (set "type" "EXPLODE" (new-map))) boulders)
	263	)
	264	; 2. else, Check collision with any missile
	265	(let* ((missile-collision-result (fold missile-collision-check (list player boulder (list)) missiles)))
	266	(list (nth 0 missile-collision-result) (nth 2 missile-collision-result) (cons (nth 1 missile-collision-result) boulders))))))
	267	(else
	268	(list (nth 0 acc) (nth 1 acc) (cons boulder (nth 2 acc))))))
	269	))
	270
	271	(define missile-collision-check (lambda (missile acc)
	272	(let* ((player (nth 0 acc))
	273	(boulder (nth 1 acc))
	274	(missiles (nth 2 acc)))
	275	(if (and (< (math.abs (- (get missile "x") (get boulder "x"))) 10)
	276	(< (math.abs (- (get missile "y") (get boulder "y"))) 10))
	277	(list
	278	(update-player player (set "type" "SCORE_POINTS" (new-map)))
	279	(update-boulder boulder (set "type" "EXPLODE" (new-map)))
	280	(cons (update-missile missile (set "type" "EXPLODE" (new-map))) missiles))
	281	(list player boulder (cons missile missiles))))
	282	))

+453

-0

src/decoy.lua less more

	0	--
	1	-- decoy.lua
	2	--
	3
	4	table = require "table"
	5
	6
	7	--[[ ========== DEBUG ========= ]]--
	8
	9	local do_debug = false
	10
	11	debug = function(s)
	12	if do_debug then
	13	print("--> (" .. s .. ")")
	14	end
	15	end
	16
	17
	18	--[[ ========== UTILS ========= ]]--
	19
	20	depict = function(sexp)
	21	local s = ""
	22	if sexp == nil then
	23	return "()"
	24	elseif sexp.class == Cons then
	25	s = s .. "("
	26	s = s .. depict(sexp.head())
	27	while sexp.tail() and sexp.tail().class == Cons do
	28	s = s .. " "
	29	s = s .. depict(sexp.tail().head())
	30	sexp = sexp.tail()
	31	end
	32	s = s .. ")"
	33	return s
	34	elseif sexp.class == Symbol then
	35	return sexp.text()
	36	elseif sexp.class == String then
	37	return "\"" .. sexp.text() .. "\""
	38	elseif sexp.class == Number then
	39	return tostring(sexp.value())
	40	else
	41	return "??" .. tostring(sexp) .. "??"
	42	end
	43	end
	44
	45
	46	--[[ ========== MODEL ========= ]]--
	47
	48	Cons = {}
	49	Cons.new = function(head, tail)
	50	local fields = {}
	51	fields.class = Cons
	52
	53	fields.head = function()
	54	return head
	55	end
	56
	57	fields.tail = function()
	58	return tail
	59	end
	60
	61	return fields
	62	end
	63
	64
	65	Symbol = {}
	66	Symbol.new = function(contents)
	67	local fields = {}
	68	fields.class = Symbol
	69
	70	fields.text = function()
	71	return contents
	72	end
	73
	74	return fields
	75	end
	76
	77
	78	String = {}
	79	String.new = function(contents)
	80	local fields = {}
	81	fields.class = String
	82
	83	fields.text = function()
	84	return contents
	85	end
	86
	87	return fields
	88	end
	89
	90
	91	Number = {}
	92	Number.new = function(contents)
	93	local fields = {}
	94	fields.class = Number
	95
	96	fields.value = function()
	97	return contents
	98	end
	99
	100	return fields
	101	end
	102
	103
	104	--[[ ========== EVALUATOR ========== ]]--
	105
	106	list_p = function(value)
	107	return false -- FIXME
	108	end
	109
	110	eval_exprs = function(sexp, env)
	111	local args = {}
	112	while sexp ~= nil do
	113	if sexp.class == Cons then
	114	table.insert(args, eval_expr(sexp.head(), env))
	115	else
	116	error("assertion failed: not a Cons")
	117	end
	118	sexp = sexp.tail()
	119	end
	120	end
	121
	122	eval_expr = function(ast, env)
	123	if ast == nil then
	124	return nil
	125	elseif ast.class == Cons then
	126	local head = ast.head()
	127	if head.class == Symbol then
	128	if head.text() == "quote" then
	129	return ast.tail().head()
	130	elseif head.text() == "car" then
	131	return eval_expr(ast.tail().head(), env).head()
	132	elseif head.text() == "cdr" then
	133	return eval_expr(ast.tail().head(), env).tail()
	134	elseif head.text() == "cons" then
	135	local a = eval_expr(ast.tail().head(), env)
	136	local b = eval_expr(ast.tail().tail().head(), env)
	137	return Cons.new(a, b)
	138	elseif head.text() == "list?'" then
	139	local a = eval_expr(ast.tail().head(), env)
	140	return Boolean.new(list_p(a))
	141	elseif head.text() == "equal?" then
	142	local a = eval_expr(ast.tail().head(), env)
	143	local b = eval_expr(ast.tail().tail().head(), env)
	144	return Boolean.new(equal_p(a, b))
	145	elseif head.text() == "let*" then
	146	local bindings = ast.tail().head()
	147	local body = ast.tail().tail().head()
	148	local new_env = bind_all(bindings, env)
	149	return eval_expr(body, new_env)
	150	elseif head.text() == "cond" then
	151	local branch = ast.tail()
	152	while branch ~= nil do
	153	local b = branch.head()
	154	local test = b.head()
	155	if test.class == Symbol and test.text() == "else" then
	156	return eval_expr(b.tail().head(), env)
	157	else
	158	local result = eval_expr(test, env)
	159	if result.class == Boolean and result.value() then
	160	return eval_expr(b.tail().head(), env)
	161	end
	162	end
	163	branch = branch.tail()
	164	end
	165	error("No else in cond")
	166	elseif head.text() == "lambda" then
	167	local formals = ast.tail().head()
	168	local body = ast.tail().tail().head()
	169	local f = function(args)
	170	--args is a table
	171	local new_env = extend_env(env, formals, args)
	172	return eval_expr(body, new_env)
	173	end
	174	return f
	175	else
	176	local fn
	177	-- print("head Symbol:", depict(head))
	178	fn = eval_expr(ast.head(), env)
	179	return fn(eval_exprs(ast.tail(), env))
	180	end
	181	else
	182	local fn
	183	-- print("head:", depict(head))
	184	fn = eval_expr(ast.head(), env)
	185	return fn(eval_exprs(ast.tail(), env))
	186	end
	187	elseif ast.class == Symbol then
	188	return env[ast.text()]
	189	-- FIXME: tell if unbound and crash if so
	190	else
	191	error("not a Cons or Atom: " .. depict(ast))
	192	end
	193	end
	194
	195
	196	--[[ ========== SCANNER ========== ]]--
	197
	198	function isdigit(s)
	199	return string.find("0123456789", s, 1, true) ~= nil
	200	end
	201
	202	function islower(s)
	203	return string.find("abcdefghijklmnopqrstuvwxyz", s, 1, true) ~= nil
	204	end
	205
	206	function isupper(s)
	207	return string.find("ABCDEFGHIJKLMNOPQRSTUVWXYZ", s, 1, true) ~= nil
	208	end
	209
	210	function isalpha(s)
	211	return islower(s) or isupper(s)
	212	end
	213
	214	function isalnum(s)
	215	return isalpha(s) or isdigit(s)
	216	end
	217
	218	function issep(s)
	219	return string.find("()", s, 1, true) ~= nil
	220	end
	221
	222	function isspace(s)
	223	return string.find(" \t\n\r", s, 1, true) ~= nil
	224	end
	225
	226	function iseol(s)
	227	return string.find("\n\r", s, 1, true) ~= nil
	228	end
	229
	230	function issymbolic(s)
	231	return (not issep(s)) and (not isspace(s))
	232	end
	233
	234	Scanner = {}
	235	Scanner.new = function(s)
	236	local string = s
	237	local _text = nil
	238	local _type = nil
	239
	240	local fields = {}
	241
	242	fields.get_token_text = function() return _text end
	243	fields.get_token_type = function() return _type end
	244
	245	fields.is_eof = function()
	246	return _type == "EOF"
	247	end
	248
	249	fields.set_token = function(text, type)
	250	_text = text
	251	_type = type
	252	debug("set_token " .. text .. " (" .. type .. ")")
	253	end
	254
	255	fields.scan = function()
	256	fields.scan_impl()
	257	debug("scanned '" .. _text .. "' (" .. _type .. ")")
	258	return _text
	259	end
	260
	261	fields.scan_impl = function()
	262	-- TODO: count pos and line
	263
	264	-- discard leading whitespace
	265	while (isspace(string:sub(1,1)) or string:sub(1,1) == ";") and string ~= "" do
	266	if isspace(string:sub(1,1)) then
	267	string = string:sub(2)
	268	elseif string:sub(1,1) == ";" then
	269	local len = 1
	270	while not iseol(string:sub(1+len,1+len)) do
	271	len = len + 1
	272	end
	273	string = string:sub(1+len)
	274	end
	275	end
	276
	277	-- check for end of input
	278	if string == "" then
	279	fields.set_token("EOF", "EOF")
	280	return
	281	end
	282
	283	-- one character token
	284	if issep(string:sub(1,1)) then
	285	local c = string:sub(1,1)
	286	string = string:sub(2)
	287	fields.set_token(c, "separator")
	288	return
	289	end
	290
	291	-- quoted string
	292	if string:sub(1,1) == "\"" then
	293	local len = 1
	294	while string:sub(1+len,1+len) ~= "\"" and len <= string:len() do
	295	len = len + 1
	296	end
	297	len = len + 1 -- skip over closing quote
	298	local word = string:sub(2, 1+len-2)
	299	string = string:sub(1+len)
	300	fields.set_token(word, "strlit")
	301	return
	302	end
	303
	304	-- else check for symbols
	305	if issymbolic(string:sub(1,1)) then
	306	local len = 0
	307	while issymbolic(string:sub(1+len,1+len)) and len <= string:len() do
	308	len = len + 1
	309	end
	310	local word = string:sub(1, 1+len-1)
	311	string = string:sub(1+len)
	312	fields.set_token(word, "symbol")
	313	return
	314	end
	315
	316	-- else check for literal decimal number
	317	if string:sub(1,1) == "-" or isdigit(string:sub(1,1)) then
	318	local len = 0
	319	if string:sub(1,1) == "-" then
	320	len = len + 1
	321	end
	322	while isdigit(string:sub(1+len,1+len)) and len <= string:len() do
	323	len = len + 1
	324	end
	325	fields.set_token(string:sub(1, len), "numlit")
	326	string = string:sub(len + 1)
	327	return
	328	end
	329
	330	-- anything else => one character token
	331	local c = string:sub(1,1)
	332	string = string:sub(2)
	333	fields.set_token(c, "operator")
	334	end
	335
	336	fields.consume = function(s)
	337	if _text == s then
	338	fields.scan()
	339	return true
	340	else
	341	return false
	342	end
	343	end
	344
	345	fields.consume_type = function(t)
	346	if _type == t then
	347	fields.scan()
	348	return true
	349	else
	350	return false
	351	end
	352	end
	353
	354	fields.expect = function(s)
	355	if _text == s then
	356	fields.scan()
	357	else
	358	error(
	359	"expected '" .. s ..
	360	"', found '" .. _text .. "'"
	361	)
	362	end
	363	end
	364
	365	debug("created scanner with string '" .. string .. "'")
	366
	367	return fields
	368	end
	369
	370
	371	Parser = {}
	372	Parser.new = function(source)
	373	local fields = {}
	374	local line = 1
	375	local pos = 0
	376	local token
	377	local scanner = Scanner.new(source)
	378
	379	local token_is = function(s) return s == scanner.get_token_text() end
	380
	381	fields.parse_exprs = function()
	382	local es = {}
	383	local e
	384	while not scanner.is_eof() do
	385	e = fields.parse_expr()
	386	table.insert(es, e)
	387	end
	388	return es
	389	end
	390
	391	fields.parse_expr = function()
	392	local e = nil
	393	if scanner.consume("(") then
	394	local es = {}
	395	local count = 0
	396	while not token_is(")") do
	397	table.insert(es, fields.parse_expr())
	398	count = count + 1
	399	end
	400	scanner.expect(")")
	401	-- accumulate into Cons list in reverse
	402	for i = count, 1, -1 do
	403	e = Cons.new(es[i], e)
	404	end
	405	elseif scanner.get_token_type() == "symbol" then
	406	e = Symbol.new(scanner.get_token_text())
	407	scanner.scan()
	408	elseif scanner.get_token_type() == "strlit" then
	409	e = String.new(scanner.get_token_text())
	410	scanner.scan()
	411	elseif scanner.get_token_type() == "numlit" then
	412	local value = tonumber(scanner.get_token_text())
	413	e = Number.new(value)
	414	scanner.scan()
	415	else
	416	error("what is this I don't even: " .. scanner.get_token_text())
	417	end
	418	return e
	419	end
	420
	421	-- init
	422	scanner.scan()
	423
	424	return fields
	425	end
	426
	427
	428	--[[ ================== MAIN =============== ]]--
	429
	430	function main(arg)
	431	local j, expr
	432	while #arg > 0 do
	433	if arg[1] == "--debug" then
	434	do_debug = true
	435	else
	436	local f = assert(io.open(arg[1], "r"))
	437	local program_text = f:read("*all")
	438	f:close()
	439
	440	local parser = Parser.new(program_text)
	441	local program = parser.parse_exprs()
	442	for j, expr in ipairs(program) do
	443	print(depict(expr))
	444	end
	445	end
	446	table.remove(arg, 1)
	447	end
	448	end
	449
	450	if arg ~= nil then
	451	main(arg)
	452	end

+63

-0

src/test_decoy.lua less more

	0	-- Usage:
	1	-- LUA_PATH="?.lua" lua test_decoy.lua
	2
	3	table = require "table"
	4
	5	r = require "decoy"
	6
	7	-- Cons cells
	8
	9	local c = Cons.new(Symbol.new("meow"), Cons.new(Symbol.new("woof"), nil))
	10
	11	print(type(c))
	12	print(depict(c.head()))
	13	print(depict(c.tail()))
	14
	15	-- Parser
	16
	17	local p, j, expr
	18
	19	p = Parser.new("(meow woof)")
	20	expr = p.parse_expr()
	21	print(depict(expr))
	22
	23	p = Parser.new("()")
	24	expr = p.parse_expr()
	25	print(depict(expr))
	26
	27	p = Parser.new([[
	28	; Not actually Scheme, just a Scheme-like language
	29
	30	(define new-map (lambda ()
	31	(quote ())
	32	))
	33
	34	(define set (lambda (key val map)
	35	(cons (cons key val) map)
	36	))
	37
	38	(define get (lambda (key map)
	39	(cond
	40	((null? map) (error "No such key"))
	41	((equal? (car (car map)) key) (cdr (car map)))
	42	(else (get key (cdr map))))
	43	))
	44
	45	(define update (lambda (key fn map)
	46	(set key (fn (get key map)) map)))
	47	]])
	48	local result = p.parse_exprs()
	49	for j, expr in ipairs(result) do
	50	print(depict(expr))
	51	end
	52
	53	function run(s)
	54	local p = Parser.new(s)
	55	local e = p.parse_expr()
	56	print("???", depict(e))
	57	local r = eval_expr(e, {})
	58	print("=", depict(r))
	59	end
	60
	61	run("(quote meow)")
	62	run("(cons (quote meow) (quote ()))")

-0

test.sh less more

	0	#!/bin/sh
	1
	2	(cd src && LUA_PATH="?.lua" lua test_decoy.lua)