--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/j4hs/Backend.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,178 @@
+module Backend where
+
+import System
+import qualified Data.ByteString.Lazy as B
+import Data.ByteString.Lazy (ByteString)
+import Numeric
+import Control.Monad
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Word
+import Data.DeriveTH
+import Data.Derive.Binary
+
+main = do args <- getArgs
+          let file = head args
+          x <- (decodeFile file :: IO ClassFile)
+          print x
+          
+newtype ClassFile = ClassFile { body :: ClassBody } deriving (Eq, Show)
+
+instance Binary ClassFile where
+  put x = do put (0xCAFEBABE :: Word32) 
+  get = do x <- (get :: Get Word32)
+           if (not $ x == 0xCAFEBABE) then fail "Insufficient magic" else liftM ClassFile get
+
+data ClassBody = ClassBody{
+  minorVersion :: Word16,
+  majorVersion :: Word16,
+  constantPool :: ConstantPool,
+  accessFlagsC :: Word16,
+  thisClass :: Word16,
+  superClass :: Word16,
+  interfaces :: Table Word16,
+  fields :: Table MemberInfo,
+  methods :: Table MemberInfo,
+  attributes :: Table AttributeInfo
+} deriving (Eq, Show)
+
+data ConstantPool = ConstantPool{
+  constantCount :: Word16,
+  constantTable :: [CPInfo]
+} deriving (Eq, Show)
+
+instance Binary ConstantPool where
+  put x = (put $ constantCount x) >> putAll (constantTable x)
+  get = do constantCount <- getWord16be
+           constantTable <- readCPEntries constantCount
+           return $ ConstantPool constantCount constantTable
+
+
+readCPEntries :: Word16 -> Get [CPInfo]
+readCPEntries n | n <= 1 = return []
+readCPEntries n = do x <- (get :: Get CPInfo) 
+                     y <- readCPEntries (n - entrySize x)
+                     return $ x : y
+                  
+entrySize :: (Integral a) => CPInfo -> a
+entrySize (ConstLong _) = 2
+entrySize (ConstDouble _) = 2
+entrySize _ = 1
+
+data Table a = Table{
+  count :: Word16,
+  table :: [a]
+} deriving (Show, Eq)
+
+instance (Binary b) => Binary (Table b) where
+  put x = (put $ count x) >> (putAll $ table x)
+  get = do count <- get
+           table <- getMany count
+           return $ Table count table 
+
+putAll :: (Binary a) => [a] -> Put
+putAll = sequence_ . map put 
+
+getMany :: (Binary a, Integral b) => b -> Get [a]
+getMany 0 = return []
+getMany n = do x <- get
+               y <- getMany $ n - 1
+               return $ x : y
+ 
+data CPInfo = 
+  ConstClass Word16
+  | ConstFieldRef Word16 Word16
+  | ConstMethodRef Word16 Word16
+  | ConstInterfaceMethodRef Word16 Word16
+  | ConstString Word16
+  | ConstInteger Word32
+  | ConstFloat Word32
+  | ConstLong Word64
+  | ConstDouble Word64
+  | ConstNameAndType Word16 Word16
+  | ConstUTF8 JUTF8
+    deriving (Eq, Show)
+
+data JUTF8 = JUTF8 { 
+  lengthU :: Word16,
+  contents :: ByteString
+} deriving (Eq, Show)
+
+instance Binary JUTF8 where
+  put x = (put $ lengthU x) >> putLazyByteString (contents x)
+
+  get = do length <- getWord16be
+           contents <- getLazyByteString (fromIntegral length) 
+           return $ JUTF8 length contents
+
+instance Binary CPInfo where
+  put (ConstClass x) = put (7 :: Word8) >> put x
+  put (ConstFieldRef x y) =  put (9 :: Word8) >> put x >> put y
+  put (ConstMethodRef x y) =  put (10 :: Word8 ) >> put x >> put y
+  put (ConstInterfaceMethodRef x y) =  put (11 :: Word8) >> put x >> put y
+  put (ConstString x) = put (8 :: Word8) >> put x
+  put (ConstInteger x) = put (3 :: Word8) >> put x
+  put (ConstFloat x) = put (4 :: Word8) >> put x
+  put (ConstLong x) = put (5 :: Word8) >> put x
+  put (ConstDouble x) = put (6 :: Word8) >> put x
+  put (ConstNameAndType x y) = put (12 :: Word8) >> put x >> put y
+
+  get = do tag <- getWord8
+           case tag of 
+             7  -> liftM ConstClass get
+             9  -> liftM2 ConstFieldRef get get
+             10 -> liftM2 ConstMethodRef get get
+             11 -> liftM2 ConstInterfaceMethodRef get get
+             8  -> liftM ConstString get
+             3  -> liftM ConstInteger get
+             4  -> liftM ConstFloat get
+             5  -> liftM ConstLong get
+             6  -> liftM ConstDouble get
+             12 -> liftM2 ConstNameAndType get get
+             1  -> liftM ConstUTF8 get
+             x  -> fail $ "Could not match " ++ show x
+
+data MemberInfo = FieldInfo{
+  memberAccessFlags :: Word16,
+  memberNameIndex :: Word16,
+  descriptorIndex :: Word16,
+  memberAttributes :: Table AttributeInfo
+} deriving (Show, Eq)
+
+data AttributeInfo = AttributeInfo{
+  nameIndex :: Word16,
+  attributeLength :: Word32,
+  attributeContents :: ByteString
+} deriving (Show, Eq)
+
+data CodeAttribute = CodeAttribute{
+  maxStack :: Word16,
+  maxLocals :: Word16,
+  codeLength :: Word32,
+  code :: ByteString,
+  exceptionTable :: Table ExceptionHandler,
+  codeAttributes :: Table AttributeInfo 
+}
+
+data ExceptionHandler = ExceptionHandler{
+  startPC :: Word16,
+  endPC :: Word16,
+  handlerPC :: Word16,
+  catchType :: Word16
+}
+
+instance Binary AttributeInfo where
+  put x = do put $ nameIndex x
+             put $ attributeLength x
+             putLazyByteString $ attributeContents x
+  get   = do nameIndex <- get
+             length <- get
+             contents <- getLazyByteString (fromIntegral length)
+             return $ AttributeInfo nameIndex length contents
+
+-- Binary derivations
+$(derive makeBinary ''MemberInfo)
+$(derive makeBinary ''ClassBody)
+$(derive makeBinary ''CodeAttribute)
+$(derive makeBinary ''ExceptionHandler)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/j4hs/EmitOpcodesModule.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,36 @@
+module Main where
+
+import Control.Monad
+import List
+
+main = do x <- liftM lines $ readFile "opcodes"          
+          let y = map ((\[u, v] -> (u, v)) . words) x
+          writeFile "Opcodes.hs" $ moduleDeclaration y
+          
+
+moduleDeclaration xs = unlines $  "module Opcodes where" : "" :  
+                                  map ("import "++) ["Data.Binary"] ++
+                                  "" : 
+                                  intersperse "" 
+                                    [ dataDeclaration ids, 
+                                      binaryInstance xs] -- ++ 
+--                                  convenienceIdentifiers ids
+  where ids = map snd xs
+                                  
+
+dataDeclaration xs = "data Opcodes = " ++ (join . (intersperse "\n  | ") $ (map ("Op_"++) xs)) ++ "  deriving (Eq, Show, Read);"
+
+binaryInstance xs = "instance Binary Instruction where\n" ++ putInstance xs ++ getInstance xs
+
+putInstance xs =  unlines $ map (\(x, y) -> "  put Op_" ++ y ++ " = put (" ++ x ++ " :: Word8 )") xs 
+getInstance xs =  join [p, 
+                        "tag <- getWord8\n" ,
+                        (replicate l ' '),
+                        "return $ case tag of\n",
+                        unlines $ map (\(x, y) -> indent ++ x ++ " -> Op_" ++ y) xs
+                        ]
+                        
+  where p = "  get = do "
+        l = length p
+        indent = replicate (l + 2) ' '
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/j4hs/Opcodes.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,624 @@
+module Opcodes where
+
+import Data.Binary
+
+data Instruction = Op_nop
+  | Op_aconst_null
+  | Op_iconst_m1
+  | Op_iconst_0
+  | Op_iconst_1
+  | Op_iconst_2
+  | Op_iconst_3
+  | Op_iconst_4
+  | Op_iconst_5
+  | Op_lconst_0
+  | Op_lconst_1
+  | Op_fconst_0
+  | Op_fconst_1
+  | Op_fconst_2
+  | Op_dconst_0
+  | Op_dconst_1
+  | Op_bipush
+  | Op_sipush
+  | Op_ldc
+  | Op_ldc_w
+  | Op_ldc2_w
+  | Op_iload
+  | Op_lload
+  | Op_fload
+  | Op_dload
+  | Op_aload
+  | Op_iload_0
+  | Op_iload_1
+  | Op_iload_2
+  | Op_iload_3
+  | Op_lload_0
+  | Op_lload_1
+  | Op_lload_2
+  | Op_lload_3
+  | Op_fload_0
+  | Op_fload_1
+  | Op_fload_2
+  | Op_fload_3
+  | Op_dload_0
+  | Op_dload_1
+  | Op_dload_2
+  | Op_dload_3
+  | Op_aload_0
+  | Op_aload_1
+  | Op_aload_2
+  | Op_aload_3
+  | Op_iaload
+  | Op_laload
+  | Op_faload
+  | Op_daload
+  | Op_aaload
+  | Op_baload
+  | Op_caload
+  | Op_saload
+  | Op_istore
+  | Op_lstore
+  | Op_fstore
+  | Op_dstore
+  | Op_astore
+  | Op_istore_0
+  | Op_istore_1
+  | Op_istore_2
+  | Op_istore_3
+  | Op_lstore_0
+  | Op_lstore_1
+  | Op_lstore_2
+  | Op_lstore_3
+  | Op_fstore_0
+  | Op_fstore_1
+  | Op_fstore_2
+  | Op_fstore_3
+  | Op_dstore_0
+  | Op_dstore_1
+  | Op_dstore_2
+  | Op_dstore_3
+  | Op_astore_0
+  | Op_astore_1
+  | Op_astore_2
+  | Op_astore_3
+  | Op_iastore
+  | Op_lastore
+  | Op_fastore
+  | Op_dastore
+  | Op_aastore
+  | Op_bastore
+  | Op_castore
+  | Op_sastore
+  | Op_pop
+  | Op_pop2
+  | Op_dup
+  | Op_dup_x1
+  | Op_dup_x2
+  | Op_dup2
+  | Op_dup2_x1
+  | Op_dup2_x2
+  | Op_swap
+  | Op_iadd
+  | Op_ladd
+  | Op_fadd
+  | Op_dadd
+  | Op_isub
+  | Op_lsub
+  | Op_fsub
+  | Op_dsub
+  | Op_imul
+  | Op_lmul
+  | Op_fmul
+  | Op_dmul
+  | Op_idiv
+  | Op_ldiv
+  | Op_fdiv
+  | Op_ddiv
+  | Op_irem
+  | Op_lrem
+  | Op_frem
+  | Op_drem
+  | Op_ineg
+  | Op_lneg
+  | Op_fneg
+  | Op_dneg
+  | Op_ishl
+  | Op_lshl
+  | Op_ishr
+  | Op_lshr
+  | Op_iushr
+  | Op_lushr
+  | Op_iand
+  | Op_land
+  | Op_ior
+  | Op_lor
+  | Op_ixor
+  | Op_lxor
+  | Op_iinc
+  | Op_i2l
+  | Op_i2f
+  | Op_i2d
+  | Op_l2i
+  | Op_l2f
+  | Op_l2d
+  | Op_f2i
+  | Op_f2l
+  | Op_f2d
+  | Op_d2i
+  | Op_d2l
+  | Op_d2f
+  | Op_i2b
+  | Op_i2c
+  | Op_i2s
+  | Op_lcmp
+  | Op_fcmpl
+  | Op_fcmpg
+  | Op_dcmpl
+  | Op_dcmpg
+  | Op_ifeq
+  | Op_ifne
+  | Op_iflt
+  | Op_ifge
+  | Op_ifgt
+  | Op_ifle
+  | Op_if_icmpeq
+  | Op_if_icmpne
+  | Op_if_icmplt
+  | Op_if_icmpge
+  | Op_if_icmpgt
+  | Op_if_icmple
+  | Op_if_acmpeq
+  | Op_if_acmpne
+  | Op_goto
+  | Op_jsr
+  | Op_ret
+  | Op_tableswitch
+  | Op_lookupswitch
+  | Op_ireturn
+  | Op_lreturn
+  | Op_freturn
+  | Op_dreturn
+  | Op_areturn
+  | Op_return
+  | Op_getstatic
+  | Op_putstatic
+  | Op_getfield
+  | Op_putfield
+  | Op_invokevirtual
+  | Op_invokespecial
+  | Op_invokestatic
+  | Op_invokeinterface
+  | Op_xxxunusedxxx
+  | Op_new
+  | Op_newarray
+  | Op_anewarray
+  | Op_arraylength
+  | Op_athrow
+  | Op_checkcast
+  | Op_instanceof
+  | Op_monitorenter
+  | Op_monitorexit
+  | Op_wide
+  | Op_multianewarray
+  | Op_ifnull
+  | Op_ifnonnull
+  | Op_goto_w
+  | Op_jsr_w
+  | Op_breakpoint
+  | Op_impdep1
+  | Op_impdep2  deriving (Eq, Show, Read);
+
+instance Binary Instruction where
+  put Op_nop = put (00 :: Word8 )
+  put Op_aconst_null = put (01 :: Word8 )
+  put Op_iconst_m1 = put (02 :: Word8 )
+  put Op_iconst_0 = put (03 :: Word8 )
+  put Op_iconst_1 = put (04 :: Word8 )
+  put Op_iconst_2 = put (05 :: Word8 )
+  put Op_iconst_3 = put (06 :: Word8 )
+  put Op_iconst_4 = put (07 :: Word8 )
+  put Op_iconst_5 = put (08 :: Word8 )
+  put Op_lconst_0 = put (09 :: Word8 )
+  put Op_lconst_1 = put (10 :: Word8 )
+  put Op_fconst_0 = put (11 :: Word8 )
+  put Op_fconst_1 = put (12 :: Word8 )
+  put Op_fconst_2 = put (13 :: Word8 )
+  put Op_dconst_0 = put (14 :: Word8 )
+  put Op_dconst_1 = put (15 :: Word8 )
+  put Op_bipush = put (16 :: Word8 )
+  put Op_sipush = put (17 :: Word8 )
+  put Op_ldc = put (18 :: Word8 )
+  put Op_ldc_w = put (19 :: Word8 )
+  put Op_ldc2_w = put (20 :: Word8 )
+  put Op_iload = put (21 :: Word8 )
+  put Op_lload = put (22 :: Word8 )
+  put Op_fload = put (23 :: Word8 )
+  put Op_dload = put (24 :: Word8 )
+  put Op_aload = put (25 :: Word8 )
+  put Op_iload_0 = put (26 :: Word8 )
+  put Op_iload_1 = put (27 :: Word8 )
+  put Op_iload_2 = put (28 :: Word8 )
+  put Op_iload_3 = put (29 :: Word8 )
+  put Op_lload_0 = put (30 :: Word8 )
+  put Op_lload_1 = put (31 :: Word8 )
+  put Op_lload_2 = put (32 :: Word8 )
+  put Op_lload_3 = put (33 :: Word8 )
+  put Op_fload_0 = put (34 :: Word8 )
+  put Op_fload_1 = put (35 :: Word8 )
+  put Op_fload_2 = put (36 :: Word8 )
+  put Op_fload_3 = put (37 :: Word8 )
+  put Op_dload_0 = put (38 :: Word8 )
+  put Op_dload_1 = put (39 :: Word8 )
+  put Op_dload_2 = put (40 :: Word8 )
+  put Op_dload_3 = put (41 :: Word8 )
+  put Op_aload_0 = put (42 :: Word8 )
+  put Op_aload_1 = put (43 :: Word8 )
+  put Op_aload_2 = put (44 :: Word8 )
+  put Op_aload_3 = put (45 :: Word8 )
+  put Op_iaload = put (46 :: Word8 )
+  put Op_laload = put (47 :: Word8 )
+  put Op_faload = put (48 :: Word8 )
+  put Op_daload = put (49 :: Word8 )
+  put Op_aaload = put (50 :: Word8 )
+  put Op_baload = put (51 :: Word8 )
+  put Op_caload = put (52 :: Word8 )
+  put Op_saload = put (53 :: Word8 )
+  put Op_istore = put (54 :: Word8 )
+  put Op_lstore = put (55 :: Word8 )
+  put Op_fstore = put (56 :: Word8 )
+  put Op_dstore = put (57 :: Word8 )
+  put Op_astore = put (58 :: Word8 )
+  put Op_istore_0 = put (59 :: Word8 )
+  put Op_istore_1 = put (60 :: Word8 )
+  put Op_istore_2 = put (61 :: Word8 )
+  put Op_istore_3 = put (62 :: Word8 )
+  put Op_lstore_0 = put (63 :: Word8 )
+  put Op_lstore_1 = put (64 :: Word8 )
+  put Op_lstore_2 = put (65 :: Word8 )
+  put Op_lstore_3 = put (66 :: Word8 )
+  put Op_fstore_0 = put (67 :: Word8 )
+  put Op_fstore_1 = put (68 :: Word8 )
+  put Op_fstore_2 = put (69 :: Word8 )
+  put Op_fstore_3 = put (70 :: Word8 )
+  put Op_dstore_0 = put (71 :: Word8 )
+  put Op_dstore_1 = put (72 :: Word8 )
+  put Op_dstore_2 = put (73 :: Word8 )
+  put Op_dstore_3 = put (74 :: Word8 )
+  put Op_astore_0 = put (75 :: Word8 )
+  put Op_astore_1 = put (76 :: Word8 )
+  put Op_astore_2 = put (77 :: Word8 )
+  put Op_astore_3 = put (78 :: Word8 )
+  put Op_iastore = put (79 :: Word8 )
+  put Op_lastore = put (80 :: Word8 )
+  put Op_fastore = put (81 :: Word8 )
+  put Op_dastore = put (82 :: Word8 )
+  put Op_aastore = put (83 :: Word8 )
+  put Op_bastore = put (84 :: Word8 )
+  put Op_castore = put (85 :: Word8 )
+  put Op_sastore = put (86 :: Word8 )
+  put Op_pop = put (87 :: Word8 )
+  put Op_pop2 = put (88 :: Word8 )
+  put Op_dup = put (089 :: Word8 )
+  put Op_dup_x1 = put (090 :: Word8 )
+  put Op_dup_x2 = put (091 :: Word8 )
+  put Op_dup2 = put (092 :: Word8 )
+  put Op_dup2_x1 = put (093 :: Word8 )
+  put Op_dup2_x2 = put (094 :: Word8 )
+  put Op_swap = put (095 :: Word8 )
+  put Op_iadd = put (096 :: Word8 )
+  put Op_ladd = put (097 :: Word8 )
+  put Op_fadd = put (098 :: Word8 )
+  put Op_dadd = put (099 :: Word8 )
+  put Op_isub = put (100 :: Word8 )
+  put Op_lsub = put (101 :: Word8 )
+  put Op_fsub = put (102 :: Word8 )
+  put Op_dsub = put (103 :: Word8 )
+  put Op_imul = put (104 :: Word8 )
+  put Op_lmul = put (105 :: Word8 )
+  put Op_fmul = put (106 :: Word8 )
+  put Op_dmul = put (107 :: Word8 )
+  put Op_idiv = put (108 :: Word8 )
+  put Op_ldiv = put (109 :: Word8 )
+  put Op_fdiv = put (110 :: Word8 )
+  put Op_ddiv = put (111 :: Word8 )
+  put Op_irem = put (112 :: Word8 )
+  put Op_lrem = put (113 :: Word8 )
+  put Op_frem = put (114 :: Word8 )
+  put Op_drem = put (115 :: Word8 )
+  put Op_ineg = put (116 :: Word8 )
+  put Op_lneg = put (117 :: Word8 )
+  put Op_fneg = put (118 :: Word8 )
+  put Op_dneg = put (119 :: Word8 )
+  put Op_ishl = put (120 :: Word8 )
+  put Op_lshl = put (121 :: Word8 )
+  put Op_ishr = put (122 :: Word8 )
+  put Op_lshr = put (123 :: Word8 )
+  put Op_iushr = put (124 :: Word8 )
+  put Op_lushr = put (125 :: Word8 )
+  put Op_iand = put (126 :: Word8 )
+  put Op_land = put (127 :: Word8 )
+  put Op_ior = put (128 :: Word8 )
+  put Op_lor = put (129 :: Word8 )
+  put Op_ixor = put (130 :: Word8 )
+  put Op_lxor = put (131 :: Word8 )
+  put Op_iinc = put (132 :: Word8 )
+  put Op_i2l = put (133 :: Word8 )
+  put Op_i2f = put (134 :: Word8 )
+  put Op_i2d = put (135 :: Word8 )
+  put Op_l2i = put (136 :: Word8 )
+  put Op_l2f = put (137 :: Word8 )
+  put Op_l2d = put (138 :: Word8 )
+  put Op_f2i = put (139 :: Word8 )
+  put Op_f2l = put (140 :: Word8 )
+  put Op_f2d = put (141 :: Word8 )
+  put Op_d2i = put (142 :: Word8 )
+  put Op_d2l = put (143 :: Word8 )
+  put Op_d2f = put (144 :: Word8 )
+  put Op_i2b = put (145 :: Word8 )
+  put Op_i2c = put (146 :: Word8 )
+  put Op_i2s = put (147 :: Word8 )
+  put Op_lcmp = put (148 :: Word8 )
+  put Op_fcmpl = put (149 :: Word8 )
+  put Op_fcmpg = put (150 :: Word8 )
+  put Op_dcmpl = put (151 :: Word8 )
+  put Op_dcmpg = put (152 :: Word8 )
+  put Op_ifeq = put (153 :: Word8 )
+  put Op_ifne = put (154 :: Word8 )
+  put Op_iflt = put (155 :: Word8 )
+  put Op_ifge = put (156 :: Word8 )
+  put Op_ifgt = put (157 :: Word8 )
+  put Op_ifle = put (158 :: Word8 )
+  put Op_if_icmpeq = put (159 :: Word8 )
+  put Op_if_icmpne = put (160 :: Word8 )
+  put Op_if_icmplt = put (161 :: Word8 )
+  put Op_if_icmpge = put (162 :: Word8 )
+  put Op_if_icmpgt = put (163 :: Word8 )
+  put Op_if_icmple = put (164 :: Word8 )
+  put Op_if_acmpeq = put (165 :: Word8 )
+  put Op_if_acmpne = put (166 :: Word8 )
+  put Op_goto = put (167 :: Word8 )
+  put Op_jsr = put (168 :: Word8 )
+  put Op_ret = put (169 :: Word8 )
+  put Op_tableswitch = put (170 :: Word8 )
+  put Op_lookupswitch = put (171 :: Word8 )
+  put Op_ireturn = put (172 :: Word8 )
+  put Op_lreturn = put (173 :: Word8 )
+  put Op_freturn = put (174 :: Word8 )
+  put Op_dreturn = put (175 :: Word8 )
+  put Op_areturn = put (176 :: Word8 )
+  put Op_return = put (177 :: Word8 )
+  put Op_getstatic = put (178 :: Word8 )
+  put Op_putstatic = put (179 :: Word8 )
+  put Op_getfield = put (180 :: Word8 )
+  put Op_putfield = put (181 :: Word8 )
+  put Op_invokevirtual = put (182 :: Word8 )
+  put Op_invokespecial = put (183 :: Word8 )
+  put Op_invokestatic = put (184 :: Word8 )
+  put Op_invokeinterface = put (185 :: Word8 )
+  put Op_xxxunusedxxx = put (186 :: Word8 )
+  put Op_new = put (187 :: Word8 )
+  put Op_newarray = put (188 :: Word8 )
+  put Op_anewarray = put (189 :: Word8 )
+  put Op_arraylength = put (190 :: Word8 )
+  put Op_athrow = put (191 :: Word8 )
+  put Op_checkcast = put (192 :: Word8 )
+  put Op_instanceof = put (193 :: Word8 )
+  put Op_monitorenter = put (194 :: Word8 )
+  put Op_monitorexit = put (195 :: Word8 )
+  put Op_wide = put (196 :: Word8 )
+  put Op_multianewarray = put (197 :: Word8 )
+  put Op_ifnull = put (198 :: Word8 )
+  put Op_ifnonnull = put (199 :: Word8 )
+  put Op_goto_w = put (200 :: Word8 )
+  put Op_jsr_w = put (201 :: Word8 )
+  put Op_breakpoint = put (202 :: Word8 )
+  put Op_impdep1 = put (254 :: Word8 )
+  put Op_impdep2 = put (255 :: Word8 )
+  get = do tag <- getWord8
+           return $ case tag of
+             00 -> Op_nop
+             01 -> Op_aconst_null
+             02 -> Op_iconst_m1
+             03 -> Op_iconst_0
+             04 -> Op_iconst_1
+             05 -> Op_iconst_2
+             06 -> Op_iconst_3
+             07 -> Op_iconst_4
+             08 -> Op_iconst_5
+             09 -> Op_lconst_0
+             10 -> Op_lconst_1
+             11 -> Op_fconst_0
+             12 -> Op_fconst_1
+             13 -> Op_fconst_2
+             14 -> Op_dconst_0
+             15 -> Op_dconst_1
+             16 -> Op_bipush
+             17 -> Op_sipush
+             18 -> Op_ldc
+             19 -> Op_ldc_w
+             20 -> Op_ldc2_w
+             21 -> Op_iload
+             22 -> Op_lload
+             23 -> Op_fload
+             24 -> Op_dload
+             25 -> Op_aload
+             26 -> Op_iload_0
+             27 -> Op_iload_1
+             28 -> Op_iload_2
+             29 -> Op_iload_3
+             30 -> Op_lload_0
+             31 -> Op_lload_1
+             32 -> Op_lload_2
+             33 -> Op_lload_3
+             34 -> Op_fload_0
+             35 -> Op_fload_1
+             36 -> Op_fload_2
+             37 -> Op_fload_3
+             38 -> Op_dload_0
+             39 -> Op_dload_1
+             40 -> Op_dload_2
+             41 -> Op_dload_3
+             42 -> Op_aload_0
+             43 -> Op_aload_1
+             44 -> Op_aload_2
+             45 -> Op_aload_3
+             46 -> Op_iaload
+             47 -> Op_laload
+             48 -> Op_faload
+             49 -> Op_daload
+             50 -> Op_aaload
+             51 -> Op_baload
+             52 -> Op_caload
+             53 -> Op_saload
+             54 -> Op_istore
+             55 -> Op_lstore
+             56 -> Op_fstore
+             57 -> Op_dstore
+             58 -> Op_astore
+             59 -> Op_istore_0
+             60 -> Op_istore_1
+             61 -> Op_istore_2
+             62 -> Op_istore_3
+             63 -> Op_lstore_0
+             64 -> Op_lstore_1
+             65 -> Op_lstore_2
+             66 -> Op_lstore_3
+             67 -> Op_fstore_0
+             68 -> Op_fstore_1
+             69 -> Op_fstore_2
+             70 -> Op_fstore_3
+             71 -> Op_dstore_0
+             72 -> Op_dstore_1
+             73 -> Op_dstore_2
+             74 -> Op_dstore_3
+             75 -> Op_astore_0
+             76 -> Op_astore_1
+             77 -> Op_astore_2
+             78 -> Op_astore_3
+             79 -> Op_iastore
+             80 -> Op_lastore
+             81 -> Op_fastore
+             82 -> Op_dastore
+             83 -> Op_aastore
+             84 -> Op_bastore
+             85 -> Op_castore
+             86 -> Op_sastore
+             87 -> Op_pop
+             88 -> Op_pop2
+             089 -> Op_dup
+             090 -> Op_dup_x1
+             091 -> Op_dup_x2
+             092 -> Op_dup2
+             093 -> Op_dup2_x1
+             094 -> Op_dup2_x2
+             095 -> Op_swap
+             096 -> Op_iadd
+             097 -> Op_ladd
+             098 -> Op_fadd
+             099 -> Op_dadd
+             100 -> Op_isub
+             101 -> Op_lsub
+             102 -> Op_fsub
+             103 -> Op_dsub
+             104 -> Op_imul
+             105 -> Op_lmul
+             106 -> Op_fmul
+             107 -> Op_dmul
+             108 -> Op_idiv
+             109 -> Op_ldiv
+             110 -> Op_fdiv
+             111 -> Op_ddiv
+             112 -> Op_irem
+             113 -> Op_lrem
+             114 -> Op_frem
+             115 -> Op_drem
+             116 -> Op_ineg
+             117 -> Op_lneg
+             118 -> Op_fneg
+             119 -> Op_dneg
+             120 -> Op_ishl
+             121 -> Op_lshl
+             122 -> Op_ishr
+             123 -> Op_lshr
+             124 -> Op_iushr
+             125 -> Op_lushr
+             126 -> Op_iand
+             127 -> Op_land
+             128 -> Op_ior
+             129 -> Op_lor
+             130 -> Op_ixor
+             131 -> Op_lxor
+             132 -> Op_iinc
+             133 -> Op_i2l
+             134 -> Op_i2f
+             135 -> Op_i2d
+             136 -> Op_l2i
+             137 -> Op_l2f
+             138 -> Op_l2d
+             139 -> Op_f2i
+             140 -> Op_f2l
+             141 -> Op_f2d
+             142 -> Op_d2i
+             143 -> Op_d2l
+             144 -> Op_d2f
+             145 -> Op_i2b
+             146 -> Op_i2c
+             147 -> Op_i2s
+             148 -> Op_lcmp
+             149 -> Op_fcmpl
+             150 -> Op_fcmpg
+             151 -> Op_dcmpl
+             152 -> Op_dcmpg
+             153 -> Op_ifeq
+             154 -> Op_ifne
+             155 -> Op_iflt
+             156 -> Op_ifge
+             157 -> Op_ifgt
+             158 -> Op_ifle
+             159 -> Op_if_icmpeq
+             160 -> Op_if_icmpne
+             161 -> Op_if_icmplt
+             162 -> Op_if_icmpge
+             163 -> Op_if_icmpgt
+             164 -> Op_if_icmple
+             165 -> Op_if_acmpeq
+             166 -> Op_if_acmpne
+             167 -> Op_goto
+             168 -> Op_jsr
+             169 -> Op_ret
+             170 -> Op_tableswitch
+             171 -> Op_lookupswitch
+             172 -> Op_ireturn
+             173 -> Op_lreturn
+             174 -> Op_freturn
+             175 -> Op_dreturn
+             176 -> Op_areturn
+             177 -> Op_return
+             178 -> Op_getstatic
+             179 -> Op_putstatic
+             180 -> Op_getfield
+             181 -> Op_putfield
+             182 -> Op_invokevirtual
+             183 -> Op_invokespecial
+             184 -> Op_invokestatic
+             185 -> Op_invokeinterface
+             186 -> Op_xxxunusedxxx
+             187 -> Op_new
+             188 -> Op_newarray
+             189 -> Op_anewarray
+             190 -> Op_arraylength
+             191 -> Op_athrow
+             192 -> Op_checkcast
+             193 -> Op_instanceof
+             194 -> Op_monitorenter
+             195 -> Op_monitorexit
+             196 -> Op_wide
+             197 -> Op_multianewarray
+             198 -> Op_ifnull
+             199 -> Op_ifnonnull
+             200 -> Op_goto_w
+             201 -> Op_jsr_w
+             202 -> Op_breakpoint
+             254 -> Op_impdep1
+             255 -> Op_impdep2
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/j4hs/ReadOpcodes.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,4 @@
+module ReadOpcodes where
+
+import Opcodes
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/j4hs/opcodes	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,205 @@
+00 nop
+01 aconst_null
+02 iconst_m1
+03 iconst_0
+04 iconst_1
+05 iconst_2
+06 iconst_3
+07 iconst_4
+08 iconst_5
+09 lconst_0
+10 lconst_1
+11 fconst_0
+12 fconst_1
+13 fconst_2
+14 dconst_0
+15 dconst_1
+16 bipush
+17 sipush
+18 ldc
+19 ldc_w
+20 ldc2_w
+21 iload
+22 lload
+23 fload
+24 dload
+25 aload
+26 iload_0
+27 iload_1
+28 iload_2
+29 iload_3
+30 lload_0
+31 lload_1
+32 lload_2
+33 lload_3
+34 fload_0
+35 fload_1
+36 fload_2
+37 fload_3
+38 dload_0
+39 dload_1
+40 dload_2
+41 dload_3
+42 aload_0
+43 aload_1
+44 aload_2
+45 aload_3
+46 iaload
+47 laload
+48 faload
+49 daload
+50 aaload
+51 baload
+52 caload
+53 saload
+54 istore
+55 lstore
+56 fstore
+57 dstore
+58 astore
+59 istore_0
+60 istore_1
+61 istore_2
+62 istore_3
+63 lstore_0
+64 lstore_1
+65 lstore_2
+66 lstore_3
+67 fstore_0
+68 fstore_1
+69 fstore_2
+70 fstore_3
+71 dstore_0
+72 dstore_1
+73 dstore_2
+74 dstore_3
+75 astore_0
+76 astore_1
+77 astore_2
+78 astore_3
+79 iastore
+80 lastore
+81 fastore
+82 dastore
+83 aastore
+84 bastore
+85 castore
+86 sastore
+87 pop
+88 pop2
+089 dup
+090 dup_x1
+091 dup_x2
+092 dup2
+093 dup2_x1
+094 dup2_x2
+095 swap
+096 iadd
+097 ladd
+098 fadd
+099 dadd
+100 isub
+101 lsub
+102 fsub
+103 dsub
+104 imul
+105 lmul
+106 fmul
+107 dmul
+108 idiv
+109 ldiv
+110 fdiv
+111 ddiv
+112 irem
+113 lrem
+114 frem
+115 drem
+116 ineg
+117 lneg
+118 fneg
+119 dneg
+120 ishl
+121 lshl
+122 ishr
+123 lshr
+124 iushr
+125 lushr
+126 iand
+127 land
+128 ior
+129 lor
+130 ixor
+131 lxor
+132 iinc
+133 i2l
+134 i2f
+135 i2d
+136 l2i
+137 l2f
+138 l2d
+139 f2i
+140 f2l
+141 f2d
+142 d2i
+143 d2l
+144 d2f
+145 i2b
+146 i2c
+147 i2s
+148 lcmp
+149 fcmpl
+150 fcmpg
+151 dcmpl
+152 dcmpg
+153 ifeq
+154 ifne
+155 iflt
+156 ifge
+157 ifgt
+158 ifle
+159 if_icmpeq
+160 if_icmpne
+161 if_icmplt
+162 if_icmpge
+163 if_icmpgt
+164 if_icmple
+165 if_acmpeq
+166 if_acmpne
+167 goto
+168 jsr
+169 ret
+170 tableswitch
+171 lookupswitch
+172 ireturn
+173 lreturn
+174 freturn
+175 dreturn
+176 areturn
+177 return
+178 getstatic
+179 putstatic
+180 getfield
+181 putfield
+182 invokevirtual
+183 invokespecial
+184 invokestatic
+185 invokeinterface
+186 xxxunusedxxx
+187 new
+188 newarray
+189 anewarray
+190 arraylength
+191 athrow
+192 checkcast
+193 instanceof
+194 monitorenter
+195 monitorexit
+196 wide
+197 multianewarray
+198 ifnull
+199 ifnonnull
+200 goto_w
+201 jsr_w
+202 breakpoint
+254 impdep1
+255 impdep2

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/spatial/CoordinateParser.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,24 @@
+module CoordinateParser 
+where
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Token
+import Text.ParserCombinators.Parsec.Language
+
+tokenParser = makeTokenParser haskellDef
+
+pointsParser :: Parser [(Double, Double)]
+pointsParser = many pointParser
+
+floatParser = do f <- option negate (char '-' >> return id) 
+                 skipMany space
+                 x <- float tokenParser
+                 return $ f x
+
+pointParser :: Parser (Double, Double)
+pointParser = do x <- floatParser
+                 skipMany space
+                 char ','
+                 skipMany space
+                 y <- floatParser
+                 return (x, y)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/spatial/QuadTree.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,66 @@
+module QuadTree
+where
+
+import Spatial
+import Control.Arrow ((&&&))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Debug.Trace
+
+data QuadTree a = 
+  Single Region (TaggedPoint a) 
+  | Empty Region
+  | Quad (Region) (QuadTree a) (QuadTree a) (QuadTree a) (QuadTree a) deriving (Show)
+
+regionOf :: QuadTree a -> Region
+regionOf (Single r _) = r
+regionOf (Empty r) = r
+regionOf (Quad r _ _ _ _) = r
+
+quadrants :: QuadTree a -> [QuadTree a]
+quadrants (Quad _ w x y z) = [w, x, y, z]
+quadrants _ = []
+
+emptyQuad :: Region -> QuadTree a
+emptyQuad r = let (tl, tr, br, bl) = mapTuple4 (Empty) $ quarter r
+               in Quad r tl tr br bl
+
+-- The smallest subtree bounding this region, or the current tree if it doesn't contain the region at all.
+bounding :: QuadTree a -> Region -> QuadTree a
+bounding x r = case (filter ((`contains` r) . regionOf) $ quadrants x) of 
+                  []  -> x
+                  y:_ -> bounding y r
+
+insert :: TaggedPoint a -> QuadTree a -> QuadTree a
+insert x (Empty r)        = Single r x
+insert x (Single r y) | (x == y) = Single r x
+insert x (Single r y) = (insert x) . (insert y) $ emptyQuad r
+insert x (Quad r tl tr br bl) = case (quadrant r $ location x) of
+                                      TL -> Quad r (insert x tl) tr br bl
+                                      TR -> Quad r tl (insert x tr) br bl
+                                      BR -> Quad r tl tr (insert x br) bl
+                                      BL -> Quad r tl tr br (insert x bl)
+
+elements :: QuadTree a -> Set (TaggedPoint a)
+elements (Empty _ ) = Set.empty
+elements (Single _ tp) = Set.singleton tp
+elements (Quad _ tl tr br bl) = Set.unions $ map elements [tl, tr, br, bl]
+
+fromSet :: Region -> Set (TaggedPoint a) -> QuadTree a
+fromSet = Set.fold insert . emptyQuad
+
+fromList :: Region -> [(TaggedPoint a)] -> QuadTree a
+fromList = foldr insert . emptyQuad
+
+fold :: (Region -> b) -> (Region -> TaggedPoint a -> b) -> (Region -> b -> b -> b -> b -> b) -> QuadTree a -> b
+fold f _ _ (Empty r) = f r
+fold _ g _ (Single r y) = g r y
+fold f g h (Quad r tl tr br bl) = let k = fold f g h 
+                                   in h r (k tl) (k tr) (k br) (k bl)
+
+instance Functor QuadTree where
+  fmap f (Empty r) = Empty r
+  fmap f (Single r p) = Single r (fmap f p)
+  fmap f (Quad r tl tr br bl) = Quad r (fmap f tl) (fmap f tr) (fmap f br) (fmap f bl)
+
+

Binary file haskell/spatial/RenderPoints has changed

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/spatial/RenderPoints.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,37 @@
+import CoordinateParser
+import Graphics.UI.GLUT
+import System
+import Text.ParserCombinators.Parsec.Prim 
+import Spatial
+import QuadTree
+
+main = do
+  args <- getArgs
+  Right points <- parseFromFile pointsParser $ args !! 0
+  (progname, _) <- getArgsAndInitialize
+  createWindow "Quad tree demo"
+  displayCallback $= display points
+  mainLoop
+
+display points = do
+  clear [ColorBuffer]
+  renderTree $ buildTree points
+  flush
+
+buildTree :: [(Double, Double)] -> QuadTree ()
+buildTree = flip (flip fromList . map (flip TP ())) $ (-1, -1) `to` (1, 1)
+
+renderRegion :: Region -> IO ()
+renderRegion r = (renderPrimitive LineLoop . (mapM_ $ vertex . uncurry Vertex2) . toList4 . corners $ r) >> flush
+
+renderPoint :: Point -> IO ()
+renderPoint p = (renderPrimitive Points . vertex . uncurry Vertex2 $ p) >> flush
+
+renderPoints :: [Point] -> IO ()
+renderPoints = mapM_ renderPoint
+
+renderTree :: QuadTree a -> IO ()
+renderTree = fold  renderRegion  
+                  (\x y -> renderRegion x >> (renderPoint . location) y)
+                  (\_ w x y z -> w >> x >> y >> z)
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/spatial/Spatial.hs	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,91 @@
+module Spatial
+where
+
+import Control.Arrow ((&&&))
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+type Point = (Double, Double)
+
+data Interval a = Interval { minValue :: a, maxValue :: a } deriving (Eq, Show)
+data Region = Region { xInterval :: Interval Double, yInterval :: Interval Double } deriving (Eq, Show) 
+
+minX = minValue . xInterval
+maxX = maxValue . xInterval
+minY = minValue . yInterval
+maxY = maxValue . yInterval
+
+to :: Point -> Point -> Region
+(x, y) `to` (u, v) = Region (Interval (min x u) (max x u)) (Interval (min y v) (max y v))
+
+extent :: (Num a) => Interval a -> a
+extent i = maxValue i - minValue i
+
+width :: Region -> Double
+width = extent . xInterval
+
+height :: Region -> Double
+height = extent . yInterval
+
+area :: Region -> Double
+area r = (extent $ yInterval r) * (extent $ xInterval r)
+
+surroundingRegion :: Point -> Double -> Region
+surroundingRegion (x, y) r = (x - r, y - r) `to` (x + r, y + r)
+
+class Container a e where
+  contains :: a -> e -> Bool
+
+instance (Ord a) => Container (Interval a) a where
+  i `contains` x = (minValue i <= x) && (maxValue i > x)
+
+instance Container Region Region where
+  r `contains` s = (minX r <= minX s) && (maxX r >= maxX s) && (minY r <= minY s) && (maxY r >= maxY s)
+
+instance Container Region Point where
+  r `contains` (x, y) = (xInterval r `contains` x) && (yInterval r `contains` y)
+
+class Centered a e | a -> e where 
+  center :: a -> e
+
+instance (Fractional a) => Centered (Interval a) a where
+  center x = (minValue x + maxValue x) / 2
+
+instance Centered Region Point where
+  center = (center . xInterval) &&& (center . yInterval)
+
+corners :: Region -> (Point, Point, Point, Point)
+corners r = ((minX r, minY r), (maxX r, minY r), (maxX r, maxY r), (minX r, maxY r))
+
+mapTuple4 :: (a -> b) -> (a, a, a, a) -> (b, b, b, b)
+mapTuple4 f (w, x, y, z) = (f w, f x, f y, f z)
+
+toList4 :: (a, a, a, a) -> [a]
+toList4 (w, x, y, z) = [w, x, y, z]
+
+midpoint :: Region -> Point
+midpoint r = ((minX r + maxX r) / 2, (minY r + maxY r) / 2)
+
+quarter :: Region -> (Region, Region, Region, Region)
+quarter r = mapTuple4 (to $ midpoint r) (corners r)
+
+data Quadrant = TL | TR | BR | BL deriving (Show, Eq)
+
+quadrant :: Region -> Point -> Quadrant
+quadrant r (x, y) = let (mx, my) = midpoint r
+                     in case (x < mx, y < my) of
+                            (True, True)  -> TL
+                            (False, True) -> TR
+                            (False, False)-> BR
+                            (True, False) -> BL
+
+data TaggedPoint a = TP { location :: Point, value :: a } deriving Show
+
+instance Eq (TaggedPoint a) where
+  x == y = location x == location y
+
+instance Ord (TaggedPoint a) where
+  x <= y = location x <= location y
+
+instance Functor TaggedPoint where
+  fmap f (TP p x) = TP p (f x)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/spatial/points	Sun Apr 20 12:30:39 2008 +0100
@@ -0,0 +1,10 @@
+0.4, 0.4
+-0.4, 0.4
+-0.4, -0.4
+0.4, -0.4
+0.1, 0.1
+0.2, 0.2
+0.3, 0.3
+0.5, 0.5
+0.6, 0.6
+0.7, 0.7