test

2026-02-20 14:47:29 -06:00
parent 8b7ad814fd
commit 442351f47d
7 changed files with 240 additions and 13 deletions
--- a/spago.lock
+++ b/spago.lock
@@ -8,10 +8,13 @@
            "arrays",
            "elmish",
            "elmish-html",
+            "foldable-traversable",
            "integers",
            "maybe",
            "numbers",
+            "ordered-collections",
            "prelude",
+            "strings",
            "tuples",
            "typelevel-prelude",
            "unsafe-coerce"
--- a/spago.yaml
+++ b/spago.yaml
@@ -23,10 +23,13 @@ package:
    - arrays
    - elmish
    - elmish-html
+    - foldable-traversable
    - integers
    - maybe
    - numbers
+    - ordered-collections
    - prelude
+    - strings
    - tuples
    - typelevel-prelude
    - unsafe-coerce
--- a/src/Mujoco.MJCF.purs
+++ b/src/Mujoco.MJCF.purs
@@ -56,8 +56,8 @@ instance Serialize Solver where

 data Enable = Disable | Enable
 instance Serialize Enable where
-  serialize Enable = "Enable"
-  serialize Disable = "Disable"
+  serialize Enable = "enable"
+  serialize Disable = "disable"

 data Coordinate = Local | Global
 instance Serialize Coordinate where
@@ -100,6 +100,7 @@ type Props_option =
  , sdf_iterations :: Int
  , sdf_initpoints :: Int
  , actuatorgroupdisable :: Array Int
+  , solver :: Solver
  )
 option = tag @Props_option "option" :: Tag Props_option

@@ -130,7 +131,7 @@ type Props_flag =
  , multiccd :: Enable
  , sleep :: Enable
  )
-flag = tag @Props_flag "flag" :: Tag Props_flag
+flag = tagNoContent @Props_flag "flag" :: TagNoContent Props_flag

 type Props_compiler =
  ( autolimits :: Boolean
--- a/src/Mujoco.XML.Node.Prop.purs
+++ b/src/Mujoco.XML.Node.Prop.purs
@@ -1,12 +1,16 @@
-module Mujoco.XML.Node.Prop (class Serialize, serialize, serializeProps, class SerializeProps', serializeProps') where
+module Mujoco.XML.Node.Prop (class Serialize, serialize, serializeProps, class SerializeProps', serializeProps', renames, unrenames) where

 import Prelude

 import Data.Array as Array
 import Data.Int as Int
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (fromMaybe)
 import Data.Number.Format (toString) as Number
 import Data.Symbol (class IsSymbol, reflectSymbol)
 import Data.Tuple (Tuple)
+import Data.Tuple as Tuple
 import Data.Tuple.Nested ((/\))
 import Prim.Row (class Cons, class Union)
 import Prim.RowList (class RowToList, RowList)
@@ -15,6 +19,12 @@ import Record.Unsafe (unsafeSet, unsafeHas, unsafeGet) as Record
 import Type.Prelude (Proxy(..))
 import Unsafe.Coerce (unsafeCoerce)

+renames :: Map String String
+renames = Map.fromFoldable ["size" /\ "mjcf:size"]
+
+unrenames :: Map String String
+unrenames = Map.fromFoldable $ map Tuple.swap $ (Map.toUnfoldable renames :: Array _)
+
 class Serialize a where
  serialize :: a -> String

@@ -60,11 +70,14 @@ instance SerializeProps' () RL.Nil where
 patchUnsafe :: forall (@k :: Symbol) a b @r @lacksK. IsSymbol k => Cons k a lacksK r => (a -> b) -> Record r -> Record r
 patchUnsafe f r =
  let
-    k = reflectSymbol $ Proxy @k
+    k' = reflectSymbol $ Proxy @k
+
+    k = fromMaybe k' $ Map.lookup k' renames
+
    btoa = unsafeCoerce :: b -> a
  in
-    if Record.unsafeHas k r then
-      Record.unsafeSet k (btoa $ f $ Record.unsafeGet k r) r
+    if Record.unsafeHas k' r then
+      Record.unsafeSet k (btoa $ f $ Record.unsafeGet k' r) r
    else
      r

--- a/src/Mujoco.XML.Node.purs
+++ b/src/Mujoco.XML.Node.purs
@@ -14,11 +14,13 @@ module Mujoco.XML.Node

 import Prelude

+import Data.FoldableWithIndex (foldlWithIndex)
+import Data.String as String
 import Elmish.HTML (empty, fragment, text) as HTML
 import Elmish.HTML.Internal (tag, tagNoContent) as HTML
 import Elmish.React (ReactElement)
-import Elmish.React as React
 import Mujoco.XML.Node.Prop (class SerializeProps', serializeProps)
+import Mujoco.XML.Node.Prop as Prop
 import Prim.Row (class Union)
 import Prim.RowList (class RowToList)
 import Unsafe.Coerce (unsafeCoerce)
@@ -29,7 +31,6 @@ type Tag props
   = forall r missing a propsrl
   . Children a
  => Union r missing props
-  => React.ValidReactProps (Record r)
  => RowToList props propsrl
  => SerializeProps' props propsrl
  => Record r
@@ -39,7 +40,6 @@ type Tag props
 type TagNoContent props
   = forall r missing propsrl
   . Union r missing props
-  => React.ValidReactProps (Record r)
  => RowToList props propsrl
  => SerializeProps' props propsrl
  => Record r
@@ -48,7 +48,15 @@ type TagNoContent props
 foreign import data Node :: Type

 render :: Node -> String
-render = renderToString <<< toReact
+render =
+  let
+    unrenameProps str =
+      foldlWithIndex unrenameProp str Prop.unrenames
+
+    unrenameProp from str to =
+      String.replaceAll (String.Pattern from) (String.Replacement to) str
+  in
+    unrenameProps <<< renderToString <<< toReact

 fromReact :: ReactElement -> Node
 fromReact = unsafeCoerce
@@ -64,7 +72,6 @@ tag
  -> ( forall r missing a.
        Union r missing props
     => Children a
-     => React.ValidReactProps (Record r)
     => Record r
     -> a
     -> Node
@@ -78,7 +85,6 @@ tagNoContent
  => String
  -> ( forall r missing.
        Union r missing props
-     => React.ValidReactProps (Record r)
     => Record r
     -> Node
     )
--- a/test/Mujoco.MJCF.purs
+++ b/test/Mujoco.MJCF.purs
@@ -4,6 +4,7 @@ import Prelude

 import Control.Monad.Error.Class (try)
 import Data.Either (isLeft)
+import Data.Tuple.Nested ((/\))
 import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
 import Mujoco.MJCF as X
@@ -18,9 +19,208 @@ ok = void <<< renderSpec
 fail :: Node -> Aff Unit
 fail = (liftEffect <<< assertTrue <<< isLeft) <=< (try <<< renderSpec)

+w :: Node -> Node
+w = X.mujoco {} <<< X.worldbody {}
+
 spec :: Spec Unit
 spec =
  describe "MJCF" do
    it "</>" $ fail $ X.empty
    it "<mujoco>" $ ok $ X.mujoco {} unit
    it "<worldbody>" $ ok $ X.mujoco {} $ X.worldbody {} unit
+
+    describe "compiler" do
+      it "empty" $ ok $ X.mujoco {}
+        [ X.compiler {}
+        , X.worldbody {} unit
+        ]
+
+      it "angle=radian" $ ok $ X.mujoco {}
+        [ X.compiler { angle: X.Radian }
+        , X.worldbody {} unit
+        ]
+
+      it "autolimits + coordinate" $ ok $ X.mujoco {}
+        [ X.compiler { autolimits: true, coordinate: X.Local }
+        , X.worldbody {} unit
+        ]
+
+      it "inertiafromgeom=auto" $ ok $ X.mujoco {}
+        [ X.compiler { inertiafromgeom: X.InertiaFromGeomAuto }
+        , X.worldbody {} unit
+        ]
+
+      it "boundmass + boundinertia" $ ok $ X.mujoco {}
+        [ X.compiler { boundmass: 0.01, boundinertia: 0.001 }
+        , X.worldbody {} unit
+        ]
+
+    describe "size" do
+      it "empty" $ ok $ X.mujoco {}
+        [ X.size {}
+        , X.worldbody {} unit
+        ]
+
+      it "memory" $ ok $ X.mujoco {}
+        [ X.size { memory: "16M" }
+        , X.worldbody {} unit
+        ]
+
+      it "nuser fields" $ ok $ X.mujoco {}
+        [ X.size { nuser_body: 2, nuser_jnt: 1, nuser_geom: 3 }
+        , X.worldbody {} unit
+        ]
+
+    describe "option" do
+      it "timestep + integrator" $ ok $ X.mujoco {}
+        [ X.option { timestep: 0.001, integrator: X.RK4 } unit
+        , X.worldbody {} unit
+        ]
+
+      it "gravity + solver" $ ok $ X.mujoco {}
+        [ X.option { gravity: 0.0 /\ 0.0 /\ (-9.81), solver: X.Newton } unit
+        , X.worldbody {} unit
+        ]
+
+    describe "statistic" do
+      it "extent + center" $ ok $ X.mujoco {}
+        [ X.statistic { extent: 2.0, center: 0.0 /\ 0.0 /\ 1.0 }
+        , X.worldbody {} unit
+        ]
+
+    describe "asset" do
+      describe "mesh" do
+        it "inline vertex" $ ok $ X.mujoco {}
+          [ X.asset {}
+              [ X.mesh { name: "tetra", vertex: [0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0] } unit ]
+          , X.worldbody {} unit
+          ]
+
+      describe "hfield" do
+        it "nrow + ncol + size" $ ok $ X.mujoco {}
+          [ X.asset {}
+              [ X.hfield { name: "terrain", nrow: 10, ncol: 10, size: 1.0 /\ 1.0 /\ 0.5 /\ 0.1 } ]
+          , X.worldbody {} unit
+          ]
+
+      describe "texture" do
+        it "procedural checker" $ ok $ X.mujoco {}
+          [ X.asset {}
+              [ X.texture
+                  { name: "grid"
+                  , type: X.Texture2d
+                  , builtin: X.BuiltinChecker
+                  , width: 512
+                  , height: 512
+                  , rgb1: 0.9 /\ 0.9 /\ 0.9
+                  , rgb2: 0.1 /\ 0.1 /\ 0.1
+                  }
+              ]
+          , X.worldbody {} unit
+          ]
+
+      describe "material" do
+        it "rgba + specular" $ ok $ X.mujoco {}
+          [ X.asset {}
+              [ X.material { name: "mat1", rgba: 0.8 /\ 0.2 /\ 0.2 /\ 1.0, specular: 0.8 } unit ]
+          , X.worldbody {} unit
+          ]
+
+    describe "body" do
+      describe "joint" do
+        it "hinge" $ ok $ w $
+          X.body { name: "b1", pos: 0.0 /\ 0.0 /\ 0.5 }
+            [ X.joint { type: X.Hinge, axis: 1.0 /\ 0.0 /\ 0.0 }
+            , X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0 } unit
+            ]
+
+        it "slide with range" $ ok $ w $
+          X.body { name: "slider", pos: 0.0 /\ 0.0 /\ 1.0 }
+            [ X.joint { type: X.Slide, axis: 0.0 /\ 0.0 /\ 1.0, range: (-1.0) /\ 1.0, limited: X.AutoBoolTrue }
+            , X.geom { type: X.GBox, size: 0.1 /\ 0.1 /\ 0.1 } unit
+            ]
+
+        it "stiffness + damping" $ ok $ w $
+          X.body { pos: 0.0 /\ 0.0 /\ 0.0 }
+            [ X.joint { type: X.Hinge, stiffness: 100.0, damping: 10.0, armature: 0.1 }
+            , X.geom { type: X.GSphere, size: 0.05 /\ 0.0 /\ 0.0 } unit
+            ]
+
+      describe "freejoint" do
+        it "basic" $ ok $ w $
+          X.body { name: "free_body", pos: 0.0 /\ 0.0 /\ 1.0 }
+            [ X.freejoint { name: "fj" }
+            , X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0 } unit
+            ]
+
+      describe "geom" do
+        it "sphere" $ ok $ w $
+          X.geom { type: X.GSphere, size: 1.0 /\ 0.0 /\ 0.0 } unit
+
+        it "capsule fromto" $ ok $ w $
+          X.geom { type: X.GCapsule, fromto: [0.0, 0.0, 0.0, 0.0, 0.0, 1.0], size: 0.05 /\ 0.0 /\ 0.0 } unit
+
+        it "box with material" $ ok $ X.mujoco {}
+          [ X.asset {}
+              [ X.material { name: "red", rgba: 1.0 /\ 0.0 /\ 0.0 /\ 1.0 } unit ]
+          , X.worldbody {} $
+              X.geom { type: X.GBox, size: 0.5 /\ 0.5 /\ 0.5, material: "red" } unit
+          ]
+
+        it "plane" $ ok $ w $
+          X.geom { type: X.GPlane, size: 5.0 /\ 5.0 /\ 0.1 } unit
+
+        it "friction + density" $ ok $ w $
+          X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0, friction: 0.5 /\ 0.005 /\ 0.0001, density: 500.0 } unit
+
+      describe "site" do
+        it "basic" $ ok $ w $
+          X.body { pos: 0.0 /\ 0.0 /\ 0.0 }
+            [ X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0 } unit
+            , X.site { name: "s1", pos: 0.0 /\ 0.0 /\ 0.1, size: 0.01 /\ 0.01 /\ 0.01 }
+            ]
+
+      describe "camera" do
+        it "fixed" $ ok $ w $
+          X.camera { name: "cam1", pos: 0.0 /\ (-2.0) /\ 1.0, fovy: 60.0 }
+
+        it "tracking" $ ok $ w $
+          X.body { name: "target_body", pos: 0.0 /\ 0.0 /\ 0.5 }
+            [ X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0 } unit
+            , X.camera { name: "tracker", mode: X.CamTargetbody, target: "target_body", pos: 1.0 /\ 0.0 /\ 0.5 }
+            ]
+
+      describe "light" do
+        it "spotlight" $ ok $ w $
+          X.light { name: "spot1", pos: 0.0 /\ 0.0 /\ 3.0, dir: 0.0 /\ 0.0 /\ (-1.0), diffuse: 1.0 /\ 1.0 /\ 1.0 }
+
+        it "directional" $ ok $ w $
+          X.light { name: "sun", type: X.LightDirectional, dir: 0.0 /\ (-1.0) /\ (-1.0), castshadow: true }
+
+      describe "inertial" do
+        it "explicit mass + diaginertia" $ ok $ w $
+          X.body { pos: 0.0 /\ 0.0 /\ 0.0 }
+            [ X.inertial { pos: 0.0 /\ 0.0 /\ 0.0, mass: 1.0, diaginertia: 0.01 /\ 0.01 /\ 0.01 }
+            , X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0 } unit
+            ]
+
+    describe "composite" do
+      it "full model"
+        $ ok
+        $ X.mujoco { model: "test" }
+            [ X.compiler { angle: X.Radian, inertiafromgeom: X.InertiaFromGeomTrue }
+            , X.option { timestep: 0.002, gravity: 0.0 /\ 0.0 /\ (-9.81) }
+                [ X.flag { contact: X.Enable } ]
+            , X.asset {}
+                [ X.texture { name: "grid", type: X.Texture2d, builtin: X.BuiltinChecker, width: 256, height: 256, rgb1: 0.9 /\ 0.9 /\ 0.9, rgb2: 0.1 /\ 0.1 /\ 0.1 }
+                , X.material { name: "floor_mat", texture: "grid", texrepeat: 5.0 /\ 5.0 } unit
+                ]
+            , X.worldbody {}
+                [ X.geom { type: X.GPlane, size: 5.0 /\ 5.0 /\ 0.1, material: "floor_mat" } unit
+                , X.light { name: "top", pos: 0.0 /\ 0.0 /\ 3.0, dir: 0.0 /\ 0.0 /\ (-1.0) }
+                , X.body { name: "ball", pos: 0.0 /\ 0.0 /\ 1.0 }
+                    [ X.freejoint {}
+                    , X.geom { type: X.GSphere, size: 0.1 /\ 0.0 /\ 0.0, rgba: 1.0 /\ 0.0 /\ 0.0 /\ 1.0 } unit
+                    ]
+                ]
+            ]
--- a/test/Mujoco.XML.Node.Prop.purs
+++ b/test/Mujoco.XML.Node.Prop.purs
@@ -33,6 +33,7 @@ spec =
      it "serializes number array" $ serialize [1.0, 2.0] `shouldEqual` "1 2"
      it "serializes tuple" $ serialize (1 /\ 2) `shouldEqual` "1 2"
      it "serializes nested tuple" $ serialize (1 /\ 2 /\ 3) `shouldEqual` "1 2 3"
+      it "serializes real(4)" $ serialize (1.0 /\ 1.0 /\ 0.5 /\ 0.1) `shouldEqual` "1 1 0.5 0.1"

    describe "SerializeProps" do
      let