vector2: integrated test suite

app/Main.hs

@@ -156,9 +156,9 @@ preludeModules carpDir = map (\s -> carpDir ++ "/core/" ++ s ++ ".carp") [ "Macr
                                                                          , "Bool"
                                                                          , "IO"
                                                                          , "System"
-                                                                         , "Test"
                                                                          , "Vector"
                                                                          , "Geometry"
+                                                                         , "Test"
                                                                          ]
 
 main :: IO ()

core/Double.carp

@@ -1,5 +1,6 @@
 (defmodule Double
   (def π 3.1415926536)
+  (register = (Fn [Double Double] Bool))
   (register < (Fn [Double Double] Bool))
   (register > (Fn [Double Double] Bool))
   (register + (Fn [Double Double] Double))
@@ -22,4 +23,10 @@
       (if (< val min)
         min
         val)))
-  )
+
+  (defn approx [x y]
+    (if (> x y)
+      (< (- x y) 0.00001)
+      (< (- y x) 0.00001)))
+
+)

core/Test.carp

@@ -1,7 +1,3 @@
-(use Bool)
-(use Int)
-(use String)
-
 (defmodule IO
   (defn color-table []
     [[@"black" @"30"]
@@ -47,7 +43,7 @@
 (defmodule Test
   (deftype State [passed Int, failed Int])
 
-  (defn handler [state expected actual descr what op]
+  (defn handler [state expected actual descr what op str]
     (if (op expected actual)
       (do
         (IO.color "green")
@@ -62,29 +58,29 @@
         (IO.color "reset")
         (State.update-failed (State.copy state) Int.inc))))
 
-  (defn assert-equal [state x y descr op]
-    (handler state x y descr "value" op))
+  (defn assert-equal [state x y descr op str]
+    (handler state x y descr "value" op str))
 
   (defn assert-str-equal [state x y descr]
-    (assert-equal state x y descr String.=))
+    (assert-equal state x y descr String.= String.str))
 
   (defn assert-int-equal [state x y descr]
-    (assert-equal state x y descr Int.=))
+    (assert-equal state x y descr Int.= Int.str))
 
   (defn assert-bool-equal [state x y descr]
-    (assert-equal state x y descr Bool.=))
+    (assert-equal state x y descr Bool.= Bool.str))
 
-  (defn assert-not-equal [state x y descr op]
-    (handler state x y descr "not value" op))
+  (defn assert-not-equal [state x y descr op str]
+    (handler state x y descr "not value" op str))
 
   (defn assert-bool-not-equal [state x y descr]
-    (assert-equal state x y descr Bool./=))
+    (assert-equal state x y descr Bool./= Bool.str))
 
   (defn assert-str-not-equal [state x y descr]
-    (assert-equal state x y descr String./=))
+    (assert-equal state x y descr String./= String.str))
 
   (defn assert-int-not-equal [state x y descr]
-    (assert-equal state x y descr Int./=))
+    (assert-equal state x y descr Int./= Int.str))
 
   (defn assert-true [state x descr]
     (assert-bool-equal state true x descr))

core/Vector.carp

@@ -1,46 +1,55 @@
 ; missing: lerp
 
-(defdynamic append-multi- [strs]
-  (if (= (count strs) 0)
-    '@""
-    (list 'String.append (car strs) (append-multi- (cdr strs)))))
-
-(defmacro append-multi [:rest strs]
-  (append-multi- strs))
-
-(defn doubleq [a, b]
-  (if (Double.> a b)
-    (Double.< (Double.- a b) 0.00001)
-    (Double.< (Double.- b a) 0.00001)))
-
 (defmodule Vector2
   (deftype V [x Double, y Double])
 
-  (defn init [x, y]
+  (defn init [x y]
     (V.init x y))
 
-  (defn str [o]
-    (append-multi @"Vector2(" (Double.str (V.x o)) @", " (Double.str (V.y o)) @")"))
+  (defn copy [v]
+    (V.copy v))
 
-  (defn + [a, b]
+  (defn get-x [o]
+    (V.x o))
+
+  (defn get-y [o]
+    (V.y o))
+
+  (defn set-x [o v]
+    (V.set-x o v))
+
+  (defn set-y [o v]
+    (V.set-y o v))
+
+  (defn str [o]
+    (string-join @"Vector2(" (Double.str (V.x o)) @", " (Double.str (V.y o)) @")"))
+
+  (defn + [a b]
     (V.init (Double.+ (V.x a) (V.x b))
             (Double.+ (V.y a) (V.y b))))
 
-  (defn - [a, b]
+  (defn - [a b]
     (V.init (Double.- (V.x a) (V.x b))
             (Double.- (V.y a) (V.y b))))
 
-  (defn * [a, n]
+  (defn * [a n]
     (V.init (Double.* (V.x a) n)
             (Double.* (V.y a) n)))
 
-  (defn / [a, n]
+  (defn / [a n]
     (V.init (Double./ (V.x a) n)
             (Double./ (V.y a) n)))
 
-  (defn = [a, b]
-    (and (doubleq (V.x a) (V.x b))
-         (doubleq (V.y a) (V.y b))))
+  (defn = [a b]
+    (and (Double.= (V.x a) (V.x b))
+         (Double.= (V.y a) (V.y b))))
+
+  (defn /= [a b]
+    (not (= a b)))
+
+  (defn approx [a b]
+    (and (Double.approx (V.x a) (V.x b))
+         (Double.approx (V.y a) (V.y b))))
 
   (defn mag-sq [o]
     (let [x (V.x o)
@@ -52,12 +61,12 @@
 
   (defn normalize [o]
     (let [m (mag o)]
-      (if (doubleq m 0.0)
+      (if (Double.= m 0.0)
         (V.copy o)
         (/ o m))))
 
-  (defn dist [a, b]
-    (let [s (- &b &a)]
+  (defn dist [a b]
+    (let [s (- b a)]
       (mag &s)))
 
   (defn heading [a]
@@ -68,7 +77,7 @@
           m (mag a)]
       (V.init (Double.* (Double.cos h) m) (Double.* (Double.sin h) m))))
 
-  (defn dot [x, y]
+  (defn dot [x y]
     (Double.+ (Double.* (V.x x) (V.x y))
               (Double.* (V.y x) (V.y y))))
 
@@ -80,28 +89,32 @@
 (defmodule Vector3
   (deftype V [x Double, y Double, z Double])
 
-  (defn init [x, y, z]
+  (defn init [x y z]
     (V.init x y z))
 
-  (defn str [o]
-    (append-multi @"Vector2(" (Double.str (V.x o)) @", " (Double.str (V.y o)) @", " (Double.str (V.z o)) @")"))
+  (defn copy [v]
+    (V.copy v))
 
-  (defn + [a, b]
+  (defn str [o]
+    (string-join @"Vector2(" (Double.str (V.x o)) @", " (Double.str (V.y o))
+                 @", " (Double.str (V.z o)) @")"))
+
+  (defn + [a b]
     (V.init (Double.+ (V.x a) (V.x b))
             (Double.+ (V.y a) (V.y b))
             (Double.+ (V.z a) (V.z b))))
 
-  (defn - [a, b]
+  (defn - [a b]
     (V.init (Double.- (V.x a) (V.x b))
             (Double.- (V.y a) (V.y b))
             (Double.- (V.z a) (V.z b))))
 
-  (defn * [a, n]
+  (defn * [a n]
     (V.init (Double.* (V.x a) n)
             (Double.* (V.y a) n)
             (Double.* (V.z a) n)))
 
-  (defn / [a, n]
+  (defn / [a n]
     (V.init (Double./ (V.x a) n)
             (Double./ (V.y a) n)
             (Double./ (V.z a) n)))
@@ -117,11 +130,11 @@
 
   (defn normalize [o]
     (let [m (mag o)]
-      (if (doubleq m 0.0)
+      (if (Double.= m 0.0)
         (V.copy o)
         (/ o m))))
 
-  (defn cross [x, y]
+  (defn cross [x y]
     (V.init
       (Double.- (Double.* (V.y x) (V.z y))
                 (Double.* (V.z x) (V.y y)))
@@ -130,7 +143,7 @@
       (Double.- (Double.* (V.x x) (V.y y))
                 (Double.* (V.y x) (V.x y)))))
 
-  (defn dot [x, y]
+  (defn dot [x y]
     (Double.+ (Double.* (V.x x) (V.x y))
               (Double.+ (Double.* (V.y x) (V.y y))
                         (Double.* (V.z x) (V.z y)))))
@@ -143,15 +156,15 @@
 ;(defmodule VectorN
 ;  (deftype V [n Int, v (Array Double)])
 ;
-;  (defn init [n, v]
+;  (defn init [n v]
 ;    (V.init n v))
 ;
 ;  (defn str [o]
-;    (append-multi @"VectorN(dim=" (Int.str (V.n o)) ;", vals=" (Array.str (V.v o))
+;    (string-join @"VectorN(dim=" (Int.str (V.n o)) ;", vals=" (Array.str (V.v o))
 ;                  @")"))
 ;
 ;  (register zip- (Fn [(Fn [Double, Double] Double) &(Array Double) &(Array Double)] V))
-;  (defn zip- [f, a, b]
+;  (defn zip- [f a b]
 ;    (let [total []]
 ;      (do
 ;        (for [i 0 (Array.count a)]
@@ -159,29 +172,29 @@
 ;        (V.init (Array.count a) total))))
 ;
 ;  (register zip (Fn [(Fn [Double, Double] Double) &V &V] V))
-;  (defn zip [f, a, b]
+;  (defn zip [f a b]
 ;    (if (Int.= (V.n a) (V.n b))
 ;      (zip- f (V.v a) (V.v b))
 ;      (do
 ;        (IO.println "Error: vectors are of wrong dimensionality")
 ;        (V.copy a))))
 ;
-;  (defn + [a, b]
+;  (defn + [a b]
 ;    (zip add- a b))
 ;
-;  (defn - [a, b]
+;  (defn - [a b]
 ;    (zip Double.- a b))
 ;
-;  (defn * [a, n]
+;  (defn * [a n]
 ;    (zip- Double.* (V.v a) &(Array.repeat (V.n a) n)))
 ;
-;  (defn / [a, n]
+;  (defn / [a n]
 ;    (zip- Double./ (V.v a) &(Array.repeat (V.n a) n)))
 ;
 ;  (defn square- [n]
 ;    (Double.* (Double.copy n) (Double.copy n)))
 ;
-;  (defn add- [x, y]
+;  (defn add- [x y]
 ;    (Double.+ (Double.copy x) (Double.copy y)))
 ;
 ;  (defn mag-sq [o]
@@ -190,7 +203,7 @@
 ;  ;(defn mag [o]
 ;  ;  (Double.sqrt (mag-sq o)))
 ;
-;  ;(defn dist [a, b]
+;  ;(defn dist [a b]
 ;  ;  (let [b (- b a)]
 ;  ;    (mag b)))
 ;

core/prelude.h

@@ -59,17 +59,18 @@ int Int_copy(int *x) { return *x; }
 float Float_copy(float *x) { return *x; }
 double Double_copy(double *x) { return *x; }
 
-#define Double__PLUS_(x, y) ((x) + (y))
-#define Double__MINUS_(x, y) ((x) - (y))
-#define Double__MUL_(x, y) ((x) * (y))
-#define Double__DIV_(x, y) ((x) / (y))
-#define Double__LT_(x, y) ((x) < (y))
-#define Double__GT_(x, y) ((x) > (y))
+double Double__PLUS_(double x, double y) { return x + y; }
+double Double__MINUS_(double x, double y) { return x - y; }
+double Double__MUL_(double x, double y) { return x * y; }
+double Double__DIV_(double x, double y) { return x / y; }
+bool Double__LT_(double x, double y) { return x < y; }
+bool Double__GT_(double x, double y) { return x > y; }
+bool Double__EQ_(double x, double y) { return x == y; }
 
-#define Float__PLUS_(x, y) ((x) + (y))
-#define Float__MINUS_(x, y) ((x) - (y))
-#define Float__MUL_(x, y) ((x) * (y))
-#define Float__DIV_(x, y) ((x) / (y))
+float Float__PLUS_(float x, float y) { return x + y; }
+float Float__MINUS_(float x, float y) { return x - y; }
+float Float__MUL_(float x, float y) { return x * y; }
+float Float__DIV_(float x, float y) { return x / y; }
 
 #define and(x, y) ((x) && (y))
 #define or(x, y) ((x) || (y))

src/Obj.hs

@@ -227,10 +227,10 @@ dependencyDepthOfTypedef _ xobj =
 
 depthOfType :: TypeEnv -> String -> Maybe Ty -> Int
 depthOfType typeEnv selfName ty = visitType ty
-  where  
+  where
     visitType :: Maybe Ty -> Int
     visitType (Just (StructTy name _)) = depthOfStructType name
-    visitType (Just (FuncTy argTys retTy)) = 
+    visitType (Just (FuncTy argTys retTy)) =
       -- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
       (maximum (visitType (Just retTy) : (map (visitType . Just) argTys))) + 1
     visitType (Just (PointerTy p)) = visitType (Just p)
@@ -304,19 +304,19 @@ envIsExternal env =
 
 -- | Find the Binder at a specified path.
 lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
-lookupInEnv (SymPath [] name) env = 
+lookupInEnv (SymPath [] name) env =
   case Map.lookup name (envBindings env) of
     Just found -> Just (env, found)
     Nothing -> case envParent env of
                  Just parent -> lookupInEnv (SymPath [] name) parent
                  Nothing -> Nothing
-lookupInEnv path@(SymPath (p : ps) name) env = 
+lookupInEnv path@(SymPath (p : ps) name) env =
   case Map.lookup p (envBindings env) of
-    Just (Binder xobj) -> 
+    Just (Binder xobj) ->
       case xobj of
         (XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv
         _ -> Nothing
-    Nothing -> 
+    Nothing ->
       case envParent env of
         Just parent -> lookupInEnv path parent
         Nothing -> Nothing
@@ -331,7 +331,7 @@ multiLookupALL = multiLookupInternal True
 -- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
 multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
 multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
-                           
+
   where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
         lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
                                         Just b -> Just (localEnv, b)
@@ -343,7 +343,7 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
                            in  envs ++ (concatMap imports envs)
                       -- Only lookup in imported modules:
                       else let envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
-                           in  envs ++ (concatMap imports envs)                               
+                           in  envs ++ (concatMap imports envs)
 
         binderToEnv :: Binder -> Maybe Env
         binderToEnv (Binder (XObj (Mod e) _ _)) = Just e
@@ -351,9 +351,9 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
 
         importsLookup :: Env -> [(Env, Binder)]
         importsLookup env = mapMaybe (lookupInLocalEnv name) (imports env)
-                            
+
         recursiveLookup :: Env -> [(Env, Binder)]
-        recursiveLookup env = 
+        recursiveLookup env =
           let spine = case Map.lookup name (envBindings env) of
                         Just found -> [(env, found)]
                         Nothing -> []
@@ -381,15 +381,17 @@ multiLookupQualified path@(SymPath (p:ps) name) rootEnv =
       case lookupInEnv path rootEnv of
         Just found -> [found]
         Nothing -> []
-    Nothing ->
-      -- No exact match on the first qualifier, will look in various places for a match:
-      let fromParent = case envParent rootEnv of
-                            Just parent -> multiLookupQualified path parent
-                            Nothing -> []
-          fromUsedModules = let usedModules = envUseModules rootEnv
-                                envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path rootEnv)) usedModules
-                            in  concatMap (\usedEnv -> multiLookupQualified path usedEnv) envs
-      in fromParent ++ fromUsedModules
+    Just _ -> inexactMatch
+    Nothing -> inexactMatch
+  where inexactMatch =
+          -- No exact match on the first qualifier, will look in various places for a match:
+          let fromParent = case envParent rootEnv of
+                                Just parent -> multiLookupQualified path parent
+                                Nothing -> []
+              fromUsedModules = let usedModules = envUseModules rootEnv
+                                    envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path rootEnv)) usedModules
+                                in  concatMap (\usedEnv -> multiLookupQualified path usedEnv) envs
+          in fromParent ++ fromUsedModules
 
 
 -- | Add an XObj to a specific environment. TODO: rename to envInsert
@@ -399,7 +401,7 @@ extendEnv env name xobj = envAddBinding env name (Binder xobj)
 -- | Add a Binder to an environment at a specific path location.
 envInsertAt :: Env -> SymPath -> XObj -> Env
 envInsertAt env (SymPath [] name) xobj = envAddBinding env name (Binder xobj)
-envInsertAt env (SymPath (p:ps) name) xobj = 
+envInsertAt env (SymPath (p:ps) name) xobj =
   case Map.lookup p (envBindings env) of
     Just (Binder (XObj (Mod innerEnv) i t)) ->
       let newInnerEnv = Binder (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
@@ -409,7 +411,7 @@ envInsertAt env (SymPath (p:ps) name) xobj =
 
 envReplaceEnvAt :: Env -> [String] -> Env -> Env
 envReplaceEnvAt _ [] replacement = replacement
-envReplaceEnvAt env (p:ps) replacement = 
+envReplaceEnvAt env (p:ps) replacement =
   case Map.lookup p (envBindings env) of
     Just (Binder (XObj (Mod innerEnv) i t)) ->
       let newInnerEnv = Binder (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
@@ -459,10 +461,10 @@ setFullyQualifiedSymbols env (XObj (Lst (defn@(XObj Defn _ _) :
   in  (XObj (Lst [defn, sym, args, setFullyQualifiedSymbols envWithArgs body]) i t)
 setFullyQualifiedSymbols env (XObj (Lst (the@(XObj The _ _) : typeXObj : value : [])) i t) =
   let value' = setFullyQualifiedSymbols env value
-  in  (XObj (Lst [the, typeXObj, value']) i t)  
+  in  (XObj (Lst [the, typeXObj, value']) i t)
 setFullyQualifiedSymbols env (XObj (Lst (def@(XObj Def _ _) : sym : expr : [])) i t) =
   let expr' = setFullyQualifiedSymbols env expr
-  in  (XObj (Lst [def, sym, expr']) i t)  
+  in  (XObj (Lst [def, sym, expr']) i t)
 setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Arr bindings) bindi bindt) : body : [])) i t) =
   if even (length bindings)
   then let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv
@@ -478,11 +480,11 @@ setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Ar
 setFullyQualifiedSymbols env (XObj (Lst xobjs) i t) =
   let xobjs' = map (setFullyQualifiedSymbols env) xobjs
   in  XObj (Lst xobjs') i t
-setFullyQualifiedSymbols env xobj@(XObj (Sym path) i t) = 
+setFullyQualifiedSymbols env xobj@(XObj (Sym path) i t) =
   case multiLookupQualified path env of
     [] -> xobj
     [(_, Binder foundOne)] -> XObj (Sym (getPath foundOne)) i t
-    multiple -> 
+    multiple ->
       case filter (not . envIsExternal . fst) multiple of
       -- There is at least one local binding, use the path of that one:
         (_, Binder local) : _ -> XObj (Sym (getPath local)) i t
@@ -528,7 +530,7 @@ instance Show Project where
 data Includer = SystemInclude String
               | LocalInclude String
               deriving Eq
-              
+
 instance Show Includer where
   show (SystemInclude file) = "<" ++ file ++ ">"
   show (LocalInclude file) = "\"" ++ file ++ "\""
@@ -650,7 +652,7 @@ defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
 defineArrayTypeAlias :: Ty -> XObj
 defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy "Array" [])
 
--- | Find out if a type is "external", meaning it is not defined by the user 
+-- | Find out if a type is "external", meaning it is not defined by the user
 --   in this program but instead imported from another C library or similar.
 isExternalType :: TypeEnv -> Ty -> Bool
 isExternalType typeEnv (PointerTy p) =

test/vector2.carp

@@ -0,0 +1,90 @@
+(use Test)
+(use Vector2)
+(use Geometry)
+
+(defn main []
+  (with-test test
+    (assert-equal test
+                  &(init 1.0 2.0) &(init 1.0 2.0)
+                  "= operator works"
+                  =
+                  str)
+    (assert-equal test
+                  &(init 1.0 2.0) &(init 1.0 1.0)
+                  "/= operator works"
+                  /=
+                  str)
+    (assert-equal test
+                  &(init 3.0 3.0)
+                  &(+ &(init 2.0 1.0) &(init 1.0 2.0))
+                  "+ operator works"
+                  =
+                  str)
+    (assert-equal test
+                  &(init 1.0 -1.0)
+                  &(- &(init 2.0 1.0) &(init 1.0 2.0))
+                  "- operator works"
+                  =
+                  str)
+    (assert-equal test
+                  &(init 4.0 2.0)
+                  &(* &(init 2.0 1.0) 2.0)
+                  "* operator works"
+                  =
+                  str)
+    (assert-equal test
+                  &(init 1.0 0.5)
+                  &(/ &(init 2.0 1.0) 2.0)
+                  "/ operator works"
+                  =
+                  str)
+    (assert-equal test
+                  5.0
+                  (mag &(init 3.0 4.0))
+                  "mag works"
+                  Double.=
+                  Double.str)
+    (assert-equal test
+                  101.0
+                  (mag-sq &(init 10.0 1.0))
+                  "mag-sq works"
+                  Double.=
+                  Double.str)
+    (assert-equal test
+                  &(init 0.6 0.8)
+                  &(normalize &(init 3.0 4.0))
+                  "normalize works"
+                  Vector2.=
+                  Vector2.str)
+    (assert-equal test
+                  5.0
+                  (dist &(init 10.0 10.0) &(init 7.0 6.0))
+                  "dist works"
+                  Double.=
+                  Double.str)
+    (assert-equal test
+                  0.0
+                  (heading &(init 1.0 0.0))
+                  "heading works"
+                  Double.=
+                  Double.str)
+    (assert-equal test
+                  &(init -2.0 1.0)
+                  &(rotate &(init 1.0 2.0) (degree-to-radians 90.0))
+                  "rotate works"
+                  Vector2.approx
+                  Vector2.str)
+    (assert-equal test
+                  90.0
+                  (radians-to-degree (Vector2.angle-between &(init 1.0 0.0) &(init 0.0 1.0)))
+                  "angle-between works"
+                  Double.approx
+                  Double.str)
+    (assert-equal test
+                  44.0
+                  (dot &(init 10.0 2.0) &(init 2.0 12.0))
+                  "dot works"
+                  Double.=
+                  Double.str)
+    (print-test-results test)
+))