moar

.gitignore

@@ -11,3 +11,4 @@
 .log
 .purs-repl
 .env
+.spec-results

package.json

@@ -9,11 +9,16 @@
   },
   "devDependencies": {
     "bun-types": "1.0.11",
+    "mujoco_wasm": "^3.2.2",
     "purs-tidy": "^0.10.0",
     "spago": "^1.0.0"
   },
   "peerDependencies": {
     "typescript": "^5.0.0"
   },
-  "dependencies": {}
+  "dependencies": {
+    "react": "17",
+    "react-dom": "17",
+    "server": "react-dom/server"
+  }
 }

spago.lock

@@ -9,6 +9,7 @@
             "elmish",
             "elmish-html",
             "integers",
+            "maybe",
             "numbers",
             "prelude",
             "tuples",
@@ -18,6 +19,8 @@
         },
         "test": {
           "dependencies": [
+            "aff-promise",
+            "assert",
             "spec",
             "spec-node"
           ]
@@ -640,6 +643,21 @@
         "unsafe-coerce"
       ]
     },
+    "aff-promise": {
+      "type": "registry",
+      "version": "4.0.0",
+      "integrity": "sha256-Jgp3y+NWuuAmwz2V3LlWoX+AvxqfVglY77N5zTw8xnI=",
+      "dependencies": [
+        "aff",
+        "control",
+        "effect",
+        "either",
+        "exceptions",
+        "foreign",
+        "prelude",
+        "transformers"
+      ]
+    },
     "ansi": {
       "type": "registry",
       "version": "7.0.0",
@@ -718,6 +736,16 @@
         "unsafe-coerce"
       ]
     },
+    "assert": {
+      "type": "registry",
+      "version": "6.0.0",
+      "integrity": "sha256-hCZ1J8/71nQiRwsSV2j7iicppScOegBFZrLI6sPf9F8=",
+      "dependencies": [
+        "console",
+        "effect",
+        "prelude"
+      ]
+    },
     "avar": {
       "type": "registry",
       "version": "5.0.1",

spago.yaml

@@ -15,6 +15,8 @@ package:
   test:
     main: Test.Main
     dependencies:
+      - aff-promise
+      - assert
       - spec
       - spec-node
   dependencies:
@@ -22,6 +24,7 @@ package:
     - elmish
     - elmish-html
     - integers
+    - maybe
     - numbers
     - prelude
     - tuples

src/Mujoco.MJCF.Asset.purs

@@ -0,0 +1,152 @@
+module Mujoco.MJCF.Asset where
+
+import Mujoco.Prelude
+
+asset = tag @() "asset" :: Tag ()
+
+data MeshInertia = Convex | Exact | Legacy | Shell
+instance Serialize MeshInertia where
+  serialize Convex = "convex"
+  serialize Exact = "exact"
+  serialize Legacy = "legacy"
+  serialize Shell = "shell"
+
+type Props_mesh =
+  ( name :: String
+  , class :: String
+  , content_type :: String
+  , file :: String
+  , scale :: Vec Real
+  , inertia :: MeshInertia
+  , smoothnormal :: Boolean
+  , maxhullvert :: Int
+  , vertex :: Array Real
+  , normal :: Array Real
+  , texcoord :: Array Real
+  , face :: Array Int
+  , refpos :: Vec Real
+  , refquat :: Vec4 Real
+  , builtin :: String
+  , params :: Array Real
+  , material :: String
+  )
+mesh = tag @Props_mesh "mesh" :: Tag Props_mesh
+
+type Props_hfield =
+  ( name :: String
+  , content_type :: String
+  , file :: String
+  , nrow :: Int
+  , ncol :: Int
+  , elevation :: Array Real
+  , size :: Vec4 Real
+  )
+hfield = tagNoContent @Props_hfield "hfield" :: TagNoContent Props_hfield
+
+data TextureType = Texture2d | TextureCube | TextureSkybox
+instance Serialize TextureType where
+  serialize Texture2d = "2d"
+  serialize TextureCube = "cube"
+  serialize TextureSkybox = "skybox"
+
+data TextureColorspace = ColorspaceAuto | ColorspaceLinear | ColorspaceSRGB
+instance Serialize TextureColorspace where
+  serialize ColorspaceAuto = "auto"
+  serialize ColorspaceLinear = "linear"
+  serialize ColorspaceSRGB = "sRGB"
+
+data TextureBuiltin = BuiltinNone | BuiltinGradient | BuiltinChecker | BuiltinFlat
+instance Serialize TextureBuiltin where
+  serialize BuiltinNone = "none"
+  serialize BuiltinGradient = "gradient"
+  serialize BuiltinChecker = "checker"
+  serialize BuiltinFlat = "flat"
+
+data TextureMark = MarkNone | MarkEdge | MarkCross | MarkRandom
+instance Serialize TextureMark where
+  serialize MarkNone = "none"
+  serialize MarkEdge = "edge"
+  serialize MarkCross = "cross"
+  serialize MarkRandom = "random"
+
+type Props_texture =
+  ( name :: String
+  , type :: TextureType
+  , colorspace :: TextureColorspace
+  , content_type :: String
+  , file :: String
+  , gridsize :: Int /\ Int
+  , gridlayout :: String
+  , fileright :: String
+  , fileleft :: String
+  , fileup :: String
+  , filedown :: String
+  , filefront :: String
+  , fileback :: String
+  , builtin :: TextureBuiltin
+  , rgb1 :: Vec Real
+  , rgb2 :: Vec Real
+  , mark :: TextureMark
+  , markrgb :: Vec Real
+  , random :: Real
+  , width :: Int
+  , height :: Int
+  , hflip :: Boolean
+  , vflip :: Boolean
+  , nchannel :: Int
+  )
+texture = tagNoContent @Props_texture "texture" :: TagNoContent Props_texture
+
+type Props_material =
+  ( name :: String
+  , class :: String
+  , texture :: String
+  , texrepeat :: Real /\ Real
+  , texuniform :: Boolean
+  , emission :: Real
+  , specular :: Real
+  , shininess :: Real
+  , reflectance :: Real
+  , metallic :: Real
+  , roughness :: Real
+  , rgba :: Vec4 Real
+  )
+material = tag @Props_material "material" :: Tag Props_material
+
+data LayerRole
+  = RoleRgb
+  | RoleNormal
+  | RoleOcclusion
+  | RoleRoughness
+  | RoleMetallic
+  | RoleOpacity
+  | RoleEmissive
+  | RoleOrm
+  | RoleRgba
+
+instance Serialize LayerRole where
+  serialize RoleRgb = "rgb"
+  serialize RoleNormal = "normal"
+  serialize RoleOcclusion = "occlusion"
+  serialize RoleRoughness = "roughness"
+  serialize RoleMetallic = "metallic"
+  serialize RoleOpacity = "opacity"
+  serialize RoleEmissive = "emissive"
+  serialize RoleOrm = "orm"
+  serialize RoleRgba = "rgba"
+
+type Props_layer =
+  ( texture :: String
+  , role :: LayerRole
+  )
+layer = tagNoContent @Props_layer "layer" :: TagNoContent Props_layer
+
+type Props_model =
+  ( name :: String
+  , file :: String
+  , content_type :: String
+  )
+model = tagNoContent @Props_model "model" :: TagNoContent Props_model
+
+type Props_plugin = (plugin :: String, instance :: String)
+plugin = tag @Props_plugin "plugin" :: Tag Props_plugin

src/Mujoco.MJCF.Body.purs

@@ -0,0 +1,248 @@
+module Mujoco.MJCF.Body where
+
+import Mujoco.Prelude
+
+data SleepPolicy = SleepAuto | SleepNever | SleepAllowed | SleepInit
+instance Serialize SleepPolicy where
+  serialize SleepAuto = "auto"
+  serialize SleepNever = "never"
+  serialize SleepAllowed = "allowed"
+  serialize SleepInit = "init"
+
+type Props_body =
+  ( name :: String
+  , childclass :: String
+  , mocap :: Boolean
+  , pos :: Vec Real
+  , quat :: Vec4 Real
+  , axisangle :: Vec4 Real
+  , xyaxes :: Array Real
+  , zaxis :: Vec Real
+  , euler :: Vec Real
+  , gravcomp :: Real
+  , sleep :: SleepPolicy
+  , user :: Array Real
+  )
+body = tag @Props_body "body" :: Tag Props_body
+worldbody = tag @Props_body "worldbody" :: Tag Props_body
+
+type Props_inertial =
+  ( pos :: Vec Real
+  , quat :: Vec4 Real
+  , axisangle :: Vec4 Real
+  , xyaxes :: Array Real
+  , zaxis :: Vec Real
+  , euler :: Vec Real
+  , mass :: Real
+  , diaginertia :: Vec Real
+  , fullinertia :: Array Real
+  )
+inertial = tagNoContent @Props_inertial "inertial" :: TagNoContent Props_inertial
+
+data JointType = Free | Ball | Slide | Hinge
+instance Serialize JointType where
+  serialize Free = "free"
+  serialize Ball = "ball"
+  serialize Slide = "slide"
+  serialize Hinge = "hinge"
+
+data AutoBool = AutoBoolFalse | AutoBoolTrue | AutoBoolAuto
+instance Serialize AutoBool where
+  serialize AutoBoolFalse = "false"
+  serialize AutoBoolTrue = "true"
+  serialize AutoBoolAuto = "auto"
+
+type Props_joint =
+  ( name :: String
+  , class :: String
+  , type :: JointType
+  , group :: Int
+  , pos :: Vec Real
+  , axis :: Vec Real
+  , springdamper :: Real /\ Real
+  , solreflimit :: Real /\ Real
+  , solimplimit :: Vec5 Real
+  , solreffriction :: Real /\ Real
+  , solimpfriction :: Vec5 Real
+  , stiffness :: Real
+  , range :: Real /\ Real
+  , limited :: AutoBool
+  , actuatorfrcrange :: Real /\ Real
+  , actuatorfrclimited :: AutoBool
+  , actuatorgravcomp :: Boolean
+  , margin :: Real
+  , ref :: Real
+  , springref :: Real
+  , armature :: Real
+  , damping :: Real
+  , frictionloss :: Real
+  , user :: Array Real
+  )
+joint = tagNoContent @Props_joint "joint" :: TagNoContent Props_joint
+
+type Props_freejoint =
+  ( name :: String
+  , group :: Int
+  , align :: AutoBool
+  )
+freejoint = tagNoContent @Props_freejoint "freejoint" :: TagNoContent Props_freejoint
+
+data GeomType = GPlane | GHfield | GSphere | GCapsule | GEllipsoid | GCylinder | GBox | GMesh | GSdf
+instance Serialize GeomType where
+  serialize GPlane = "plane"
+  serialize GHfield = "hfield"
+  serialize GSphere = "sphere"
+  serialize GCapsule = "capsule"
+  serialize GEllipsoid = "ellipsoid"
+  serialize GCylinder = "cylinder"
+  serialize GBox = "box"
+  serialize GMesh = "mesh"
+  serialize GSdf = "sdf"
+
+data FluidShape = FluidNone | FluidEllipsoid
+instance Serialize FluidShape where
+  serialize FluidNone = "none"
+  serialize FluidEllipsoid = "ellipsoid"
+
+type Props_geom =
+  ( name :: String
+  , class :: String
+  , type :: GeomType
+  , contype :: Int
+  , conaffinity :: Int
+  , condim :: Int
+  , group :: Int
+  , priority :: Int
+  , size :: Vec Real
+  , material :: String
+  , rgba :: Vec4 Real
+  , friction :: Vec Real
+  , mass :: Real
+  , density :: Real
+  , shellinertia :: Boolean
+  , solmix :: Real
+  , solref :: Real /\ Real
+  , solimp :: Vec5 Real
+  , margin :: Real
+  , gap :: Real
+  , fromto :: Array Real
+  , pos :: Vec Real
+  , quat :: Vec4 Real
+  , axisangle :: Vec4 Real
+  , xyaxes :: Array Real
+  , zaxis :: Vec Real
+  , euler :: Vec Real
+  , hfield :: String
+  , mesh :: String
+  , fitscale :: Real
+  , fluidshape :: FluidShape
+  , fluidcoef :: Vec5 Real
+  , user :: Array Real
+  )
+geom = tag @Props_geom "geom" :: Tag Props_geom
+
+data SiteType = SiteSphere | SiteCapsule | SiteEllipsoid | SiteCylinder | SiteBox
+instance Serialize SiteType where
+  serialize SiteSphere = "sphere"
+  serialize SiteCapsule = "capsule"
+  serialize SiteEllipsoid = "ellipsoid"
+  serialize SiteCylinder = "cylinder"
+  serialize SiteBox = "box"
+
+type Props_site =
+  ( name :: String
+  , class :: String
+  , type :: SiteType
+  , group :: Int
+  , material :: String
+  , rgba :: Vec4 Real
+  , size :: Vec Real
+  , fromto :: Array Real
+  , pos :: Vec Real
+  , quat :: Vec4 Real
+  , axisangle :: Vec4 Real
+  , xyaxes :: Array Real
+  , zaxis :: Vec Real
+  , euler :: Vec Real
+  , user :: Array Real
+  )
+site = tagNoContent @Props_site "site" :: TagNoContent Props_site
+
+data CameraMode = CamFixed | CamTrack | CamTrackcom | CamTargetbody | CamTargetbodycom
+instance Serialize CameraMode where
+  serialize CamFixed = "fixed"
+  serialize CamTrack = "track"
+  serialize CamTrackcom = "trackcom"
+  serialize CamTargetbody = "targetbody"
+  serialize CamTargetbodycom = "targetbodycom"
+
+data Projection = Perspective | Orthographic
+instance Serialize Projection where
+  serialize Perspective = "perspective"
+  serialize Orthographic = "orthographic"
+
+data CameraOutput = OutputRgb | OutputDepth | OutputDistance | OutputNormal | OutputSegmentation
+instance Serialize CameraOutput where
+  serialize OutputRgb = "rgb"
+  serialize OutputDepth = "depth"
+  serialize OutputDistance = "distance"
+  serialize OutputNormal = "normal"
+  serialize OutputSegmentation = "segmentation"
+
+type Props_camera =
+  ( name :: String
+  , class :: String
+  , mode :: CameraMode
+  , target :: String
+  , projection :: Projection
+  , fovy :: Real
+  , resolution :: Int /\ Int
+  , output :: CameraOutput
+  , sensorsize :: Real /\ Real
+  , focal :: Real /\ Real
+  , focalpixel :: Real /\ Real
+  , principal :: Real /\ Real
+  , principalpixel :: Real /\ Real
+  , ipd :: Real
+  , pos :: Vec Real
+  , quat :: Vec4 Real
+  , axisangle :: Vec4 Real
+  , xyaxes :: Array Real
+  , zaxis :: Vec Real
+  , euler :: Vec Real
+  , user :: Array Real
+  )
+camera = tagNoContent @Props_camera "camera" :: TagNoContent Props_camera
+
+data LightType = LightSpot | LightDirectional | LightPoint | LightImage
+instance Serialize LightType where
+  serialize LightSpot = "spot"
+  serialize LightDirectional = "directional"
+  serialize LightPoint = "point"
+  serialize LightImage = "image"
+
+type Props_light =
+  ( name :: String
+  , class :: String
+  , mode :: CameraMode
+  , target :: String
+  , type :: LightType
+  , directional :: Boolean
+  , castshadow :: Boolean
+  , active :: Boolean
+  , pos :: Vec Real
+  , dir :: Vec Real
+  , diffuse :: Vec Real
+  , texture :: String
+  , intensity :: Real
+  , ambient :: Vec Real
+  , specular :: Vec Real
+  , range :: Real
+  , bulbradius :: Real
+  , attenuation :: Vec Real
+  , cutoff :: Real
+  , exponent :: Real
+  )
+light = tagNoContent @Props_light "light" :: TagNoContent Props_light
+
+-- TODO: body/composite reuses row types of joint, geom, site, skin, plugin

src/Mujoco.MJCF.purs

@@ -1,6 +1,32 @@
-module Mujoco.MJCF where
+module Mujoco.MJCF
+  ( Angle(..)
+  , Cone(..)
+  , Coordinate(..)
+  , Enable(..)
+  , InertiaFromGeom(..)
+  , Integrator(..)
+  , Jacobian(..)
+  , Props_compiler
+  , Props_flag
+  , Props_option
+  , Props_size
+  , Props_mujoco
+  , Props_statistic
+  , Solver(..)
+  , compiler
+  , flag
+  , mujoco
+  , option
+  , size
+  , statistic
+  , module X
+  )
+  where
 
 import Mujoco.Prelude
+import Mujoco.MJCF.Asset as X
+import Mujoco.MJCF.Body as X
+import Mujoco.XML.Node (empty, text, fragment) as X
 
 type Props_mujoco = (model :: String)
 mujoco = tag @Props_mujoco "mujoco" :: Tag Props_mujoco
@@ -147,3 +173,13 @@ type Props_size =
   , nuser_sensor :: Int
   )
 size = tagNoContent @Props_size "size" :: TagNoContent Props_size
+
+type Props_statistic =
+  ( meanmass :: Real
+  , meaninertia :: Real
+  , meansize :: Real
+  , extent :: Real
+  , center :: Vec Real
+  )
+statistic = tagNoContent @Props_statistic "statistic" :: TagNoContent Props_statistic
+

src/Mujoco.XML.Node.js

@@ -0,0 +1,4 @@
+import ReactDOM from 'react-dom/server.js'
+
+/** @type {(node: import('react').ReactElement) => String} */
+export const renderToString = el => ReactDOM.renderToStaticMarkup(el)

src/Mujoco.XML.Node.purs

@@ -23,6 +23,8 @@ import Prim.Row (class Union)
 import Prim.RowList (class RowToList)
 import Unsafe.Coerce (unsafeCoerce)
 
+foreign import renderToString :: ReactElement -> String
+
 type Tag props
    = forall r missing a propsrl
    . Children a
@@ -46,7 +48,7 @@ type TagNoContent props
 foreign import data Node :: Type
 
 render :: Node -> String
-render = React.renderToString <<< toReact
+render = renderToString <<< toReact
 
 fromReact :: ReactElement -> Node
 fromReact = unsafeCoerce

test/Main.purs

@@ -4,10 +4,12 @@ import Prelude
 
 import Effect (Effect)
 import Test.Mujoco.XML.Node.Prop as Test.Mujoco.XML.Node.Prop
+import Test.Mujoco.MJCF as Test.Mujoco.MJCF
 import Test.Spec.Reporter.Console (consoleReporter)
 import Test.Spec.Runner.Node (runSpecAndExitProcess)
 
 main :: Effect Unit
 main =
   runSpecAndExitProcess [consoleReporter] do
+    Test.Mujoco.MJCF.spec
     Test.Mujoco.XML.Node.Prop.spec

test/Mujoco.MJCF.purs

@@ -0,0 +1,26 @@
+module Test.Mujoco.MJCF where
+
+import Prelude
+
+import Control.Monad.Error.Class (try)
+import Data.Either (isLeft)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Mujoco.MJCF as X
+import Mujoco.Wasm (renderSpec)
+import Mujoco.XML.Node (Node)
+import Test.Assert (assertTrue)
+import Test.Spec (Spec, describe, it)
+
+ok :: Node -> Aff Unit
+ok = void <<< renderSpec
+
+fail :: Node -> Aff Unit
+fail = (liftEffect <<< assertTrue <<< isLeft) <=< (try <<< renderSpec)
+
+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

test/Mujoco.Wasm.js

@@ -0,0 +1,10 @@
+import load_mujoco from 'mujoco_wasm/mujoco_wasm.js'
+
+/** @typedef {import('mujoco_wasm').MainModule} Mujoco */
+/** @typedef {import('mujoco_wasm').MjSpec} Spec */
+
+/** @type {() => Promise<Mujoco>} */
+export const loadMujoco = () => load_mujoco()
+
+/** @type {(mj: Mujoco) => (xml: String) => () => Spec} */
+export const parseXMLString = m => xml => () => m.parseXMLString(xml)

test/Mujoco.Wasm.purs

@@ -0,0 +1,21 @@
+module Mujoco.Wasm where
+
+import Prelude
+
+import Control.Promise (Promise)
+import Control.Promise as Promise
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Mujoco.XML.Node as XML
+
+foreign import data Mujoco :: Type
+foreign import data Spec :: Type
+
+foreign import loadMujoco :: Effect (Promise Mujoco)
+foreign import parseXMLString :: Mujoco -> String -> Effect Spec
+
+renderSpec :: XML.Node -> Aff Spec
+renderSpec node = do
+  mj <- Promise.toAffE loadMujoco
+  liftEffect $ parseXMLString mj $ XML.render node