From 0850162d43380f080cce973de585b82f1f5d594f Mon Sep 17 00:00:00 2001
From: Cat's Eye Technologies <cpressey@catseye.tc>
Date: Thu, 3 Apr 2014 20:29:43 +0100
Subject: [PATCH] Improve game slightly.  Add foldRoutine*, use in checker.

---
 README.markdown           |  1 +
 eg/game.60p               | 65 +++++++++++++++++++++++++--------------
 src/SixtyPical/Checker.hs | 12 ++++----
 src/SixtyPical/Model.hs   | 28 ++++++++++++++++-
 4 files changed, 76 insertions(+), 30 deletions(-)

diff --git a/README.markdown b/README.markdown
index 62a78cb..0863140 100644
--- a/README.markdown
+++ b/README.markdown
@@ -183,3 +183,4 @@ TODO
 *   `jsr (vector)`
 *   `jmp routine`
 *   insist on EOL after each instruction.  need spacesWOEOL production
+*   `copy immediate word`
diff --git a/eg/game.60p b/eg/game.60p
index a4397da..8f2d9fd 100644
--- a/eg/game.60p
+++ b/eg/game.60p
@@ -18,7 +18,10 @@ assign vector cinv 788
 ; ---------
 
 reserve vector save_cinv
+
 assign word position $fb
+assign word new_position $fd
+
 reserve word delta
 reserve byte value
 reserve word compare_target
@@ -45,27 +48,11 @@ routine our_cinv {
     sta (position), y
     jsr read_stick
     jsr advance_pos
-
-    lda #$07                 ; just past bottom of screen
-    sta >compare_target
-    lda #$e8
-    sta <compare_target
-    jsr compare_pos
-
+    jsr check_new_position_in_bounds
     if bcs {
-        jsr reset_position
-    } else {
+        jsr install_new_position
+    } else { }
 
-        lda #$04
-        sta >compare_target
-        lda #$00
-        sta <compare_target
-        jsr compare_pos
-
-        if bcc {
-            jsr reset_position
-        } else { }
-    }
     jmp (save_cinv)
 }
 
@@ -80,17 +67,49 @@ routine advance_pos {
     clc
     lda <position
     adc <delta
-    sta <position
+    sta <new_position
     lda >position
     adc >delta
+    sta >new_position
+}
+
+routine install_new_position {
+    lda <new_position
+    sta <position
+    lda >new_position
     sta >position
 }
 
-routine compare_pos {
-    lda >position
+routine check_new_position_in_bounds {
+    lda #$07                 ; just past bottom of screen
+    sta >compare_target
+    lda #$e8
+    sta <compare_target
+    jsr compare_new_pos
+
+    if bcs {
+        clc
+    } else {
+
+        lda #$04
+        sta >compare_target
+        lda #$00
+        sta <compare_target
+        jsr compare_new_pos
+
+        if bcc {
+            clc
+        } else {
+            sec
+        }
+    }
+}
+
+routine compare_new_pos {
+    lda >new_position
     cmp >compare_target
     if beq {
-        lda <position
+        lda <new_position
         cmp <compare_target
     } else {
     }
diff --git a/src/SixtyPical/Checker.hs b/src/SixtyPical/Checker.hs
index 7f698b7..ab4c2a7 100644
--- a/src/SixtyPical/Checker.hs
+++ b/src/SixtyPical/Checker.hs
@@ -38,17 +38,17 @@ noIndexedAccessOfNonTables p@(Program decls routines) =
 
 noUseOfUndeclaredRoutines p@(Program decls routines) =
     let
-        mappedProgram = mapProgramRoutines (checkInstr) p
+        undeclaredRoutines = foldProgramRoutines (checkInstr) 0 p
     in
-        mappedProgram == p
+        undeclaredRoutines == 0
     where
         routineNames = declaredRoutineNames p
         -- TODO also check COPYROUTINE here
-        checkInstr j@(JSR routName) =
+        checkInstr j@(JSR routName) acc =
             case routName `elem` routineNames of
-                True -> j
-                False -> (COPY A A)
-        checkInstr other = other
+                True -> acc
+                False -> error ("undeclared routine '" ++ routName ++ "'") -- acc + 1
+        checkInstr other acc = acc
 
 -- -- -- -- -- --
 
diff --git a/src/SixtyPical/Model.hs b/src/SixtyPical/Model.hs
index 6035273..a9a0345 100644
--- a/src/SixtyPical/Model.hs
+++ b/src/SixtyPical/Model.hs
@@ -125,6 +125,8 @@ declaredRoutineNames (Program decls routines) =
 routineDeclared routName p =
     elem routName (declaredRoutineNames p)
 
+--
+
 mapBlock :: (Instruction -> Instruction) -> [Instruction] -> [Instruction]
 mapBlock = map
 
@@ -137,7 +139,31 @@ mapRoutines f (rout:routs) =
     (mapRoutine f rout):(mapRoutines f routs)
 
 mapProgramRoutines :: (Instruction -> Instruction) -> Program -> Program
-mapProgramRoutines f (Program decls routs) = Program decls $ mapRoutines f routs
+mapProgramRoutines f (Program decls routs) =
+    Program decls $ mapRoutines f routs
+
+--
+
+foldBlock :: (Instruction -> a -> a) -> a -> [Instruction] -> a
+foldBlock = foldr
+
+foldRoutine :: (Instruction -> a -> a) -> a -> Routine -> a
+foldRoutine f a (Routine name instrs) =
+    foldBlock f a instrs
+
+foldRoutines :: (Instruction -> a -> a) -> a -> [Routine] -> a
+foldRoutines f a [] = a
+foldRoutines f a (rout:routs) =
+    let
+        z = foldRoutine f a rout
+    in
+        foldRoutines f z routs
+
+foldProgramRoutines :: (Instruction -> a -> a) -> a -> Program -> a
+foldProgramRoutines f a (Program decls routs) =
+    foldRoutines f a routs
+
+--
 
 lookupDecl (Program decls _) name =
     lookupDecl' (filter (isLocationDecl) decls) name