diff options
Diffstat (limited to 'users/grfn/xanthous/src')
8 files changed, 196 insertions, 22 deletions
diff --git a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs index 34f2a94038..e89fcd6211 100644 --- a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs +++ b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs @@ -89,7 +89,8 @@ type TagSingleConstructors = 'TagSingleConstructors class Demotable (a :: k) where demote :: proxy a -> Demoted k -type family All (p :: Type -> Constraint) (xs :: [k]) :: Constraint where +type All :: (Type -> Constraint) -> [Type] -> Constraint +type family All p xs where All p '[] = () All p (x ': xs) = (p x, All p xs) diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 1e915a03fe..6ed545e3aa 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -32,6 +32,7 @@ import Xanthous.Data , position , Position , (|*|) + , Tiles(..) ) import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) import qualified Xanthous.Data.EntityMap as EntityMap @@ -127,7 +128,7 @@ handleCommand (Move dir) = do collisionAt newPos >>= \case Nothing -> do characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 1) + stepGameBy =<< uses (character . speed) (|*| Tiles 1) describeEntitiesAt newPos Just Combat -> attackAt newPos Just Stop -> pure () diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs index 5892536137..5d4db1a474 100644 --- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs +++ b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs @@ -30,7 +30,7 @@ autoStep (AutoMove dir) = do collisionAt newPos >>= \case Nothing -> do characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 1) + stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles)) describeEntitiesAt newPos cancelIfDanger Just _ -> cancelAutocommand diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs index c9c11b553b..89d0993b4e 100644 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ b/users/grfn/xanthous/src/Xanthous/Data.hs @@ -3,8 +3,6 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoTypeSynonymInstances #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -56,6 +54,10 @@ module Xanthous.Data , TicksPerTile , TilesPerTick , timesTiles + , Square(..) + , Cubic(..) + , Grams + , Meters -- * , Dimensions'(..) @@ -490,9 +492,9 @@ rotations orig@(Neighbors tl t tr l r bl b br) = V4 newtype Per a b = Rate Double deriving stock (Show, Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double + deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) + via Double deriving (Semigroup, Monoid) via Product Double -instance Arbitrary (Per a b) where arbitrary = genericArbitrary invertRate :: a `Per` b -> b `Per` a invertRate (Rate p) = Rate $ 1 / p @@ -500,9 +502,42 @@ invertRate (Rate p) = Rate $ 1 / p invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') invertedRate = iso invertRate invertRate +type (:*:) :: Type -> Type -> Type +type family (:*:) a b where + (a `Per` b) :*: b = a + (Square a) :*: a = Cubic a + a :*: a = Square a + infixl 7 |*| -(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a -(|*|) (Rate rate) b = fromScalar $ rate * scalar b +class MulUnit a b where + (|*|) :: a -> b -> a :*: b + +instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where + (Rate rate) |*| b = fromScalar $ rate * scalar b + +instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where + x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y' + +instance forall a. (Scalar a) => MulUnit (Square a) a where + x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y' + +newtype Square a = Square a + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a + +newtype Cubic a = Cubic a + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a + +-------------------------------------------------------------------------------- newtype Ticks = Ticks Word deriving stock (Show, Eq, Generic) @@ -510,14 +545,14 @@ newtype Ticks = Ticks Word deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word deriving (Semigroup, Monoid) via (Sum Word) deriving Scalar via ScalarIntegral Ticks -instance Arbitrary Ticks where arbitrary = genericArbitrary + deriving Arbitrary via GenericArbitrary Ticks newtype Tiles = Tiles Double deriving stock (Show, Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double deriving (Semigroup, Monoid) via (Sum Double) -instance Arbitrary Tiles where arbitrary = genericArbitrary + deriving Arbitrary via GenericArbitrary Tiles type TicksPerTile = Ticks `Per` Tiles type TilesPerTick = Tiles `Per` Ticks @@ -536,6 +571,23 @@ newtype Hitpoints = Hitpoints Word -------------------------------------------------------------------------------- +-- | Grams, the fundamental measure of weight in Xanthous. +newtype Grams = Grams Double + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat + , RealFrac, Scalar, ToJSON, FromJSON + ) + via Double + deriving (Semigroup, Monoid) via Sum Double + +-- | Every tile is 1 meter +type Meters = Tiles + + + +-------------------------------------------------------------------------------- + data Box a = Box { _topLeftCorner :: V2 a , _dimensions :: V2 a diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs index b7c5fe31c9..88070ed7b8 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs @@ -51,11 +51,12 @@ import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Messages (Message(..)) -import Xanthous.Data (TicksPerTile, Hitpoints) +import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters) import Xanthous.Data.EntityChar import Xanthous.Util.QuickCheck import Xanthous.Generators.Speech (Language, gormlak, english) import Xanthous.Orphans () +import Data.Interval (Interval, lowerBound', upperBound') -------------------------------------------------------------------------------- -- | Identifiers for languages that creatures can speak. @@ -153,10 +154,12 @@ data ItemType = ItemType , _description :: !Text , _longDescription :: !Text , _char :: !EntityChar + , _density :: !(Interval (Grams `Per` Cubic Meters)) + , _volume :: !(Interval (Cubic Meters)) , _edible :: !(Maybe EdibleItem) , _wieldable :: !(Maybe WieldableItem) } - deriving stock (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving Arbitrary via GenericArbitrary ItemType deriving (ToJSON, FromJSON) @@ -164,6 +167,20 @@ data ItemType = ItemType ItemType makeFieldsNoPrefix ''ItemType +instance Ord ItemType where + compare x y + = compareOf name x y + <> compareOf description x y + <> compareOf longDescription x y + <> compareOf char x y + <> compareOf (density . to extractInterval) x y + <> compareOf (volume . to extractInterval) x y + <> compareOf edible x y + <> compareOf wieldable x y + where + compareOf l = comparing (view l) + extractInterval = lowerBound' &&& upperBound' + -- | Can this item be eaten? isEdible :: ItemType -> Bool isEdible = has $ edible . _Just diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml index c3f19dce91..c0501a18a8 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml @@ -10,3 +10,5 @@ Item: hitpointsHealed: 2 eatMessage: - You slurp up the noodles. Yumm! + density: 500000 + volume: 0.001 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml index bc7fde4d8b..4100808ca0 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml @@ -12,3 +12,7 @@ Item: - You bonk the {{creature.creatureType.name}} over the head with your stick. - You bash the {{creature.creatureType.name}} on the noggin with your stick. - You whack the {{creature.creatureType.name}} with your stick. + # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density + # it's a hard stick. so it's dense wood. + density: 890000 # g/m³ + volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs index e6ea131031..0b282af44c 100644 --- a/users/grfn/xanthous/src/Xanthous/Orphans.hs +++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} -------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-deferred-type-errors #-} module Xanthous.Orphans ( ppTemplate ) where @@ -28,11 +28,15 @@ import Text.Mustache import Text.Mustache.Type ( showKey ) import Control.Monad.State import Linear +import qualified Data.Interval as Interval +import Data.Interval ( Interval, Extended (..), Boundary (..) + , lowerBound', upperBound', (<=..<), (<=..<=) + , interval) +import Test.QuickCheck.Checkers (EqProp ((=-=))) -------------------------------------------------------------------------------- import Xanthous.Util.JSON import Xanthous.Util.QuickCheck -import qualified Data.Interval as Interval -import Data.Interval (Interval, Extended (..)) +import Xanthous.Util (EqEqProp(EqEqProp)) -------------------------------------------------------------------------------- instance forall s a. @@ -241,6 +245,8 @@ instance CoArbitrary a => CoArbitrary (MaybeDefault a) where instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where function = functionShow +deriving via (EqEqProp Attr) instance EqProp Attr + instance Arbitrary Attr where arbitrary = do attrStyle <- arbitrary @@ -367,12 +373,46 @@ instance Function a => Function (V2 a) -------------------------------------------------------------------------------- -instance Arbitrary r => Arbitrary (Extended r) where +instance CoArbitrary Boundary +instance Function Boundary + +instance Arbitrary a => Arbitrary (Extended a) where arbitrary = oneof [ pure NegInf , pure PosInf , Finite <$> arbitrary ] +instance CoArbitrary a => CoArbitrary (Extended a) where + coarbitrary NegInf = variant 1 + coarbitrary PosInf = variant 2 + coarbitrary (Finite x) = variant 3 . coarbitrary x + +instance (Function a) => Function (Extended a) where + function = functionMap g h + where + g NegInf = Left True + g (Finite a) = Right a + g PosInf = Left False + h (Left False) = PosInf + h (Left True) = NegInf + h (Right a) = Finite a + +instance ToJSON a => ToJSON (Extended a) where + toJSON NegInf = String "NegInf" + toJSON PosInf = String "PosInf" + toJSON (Finite x) = toJSON x + +instance FromJSON a => FromJSON (Extended a) where + parseJSON (String "NegInf") = pure NegInf + parseJSON (String "PosInf") = pure PosInf + parseJSON val = Finite <$> parseJSON val + +instance (EqProp a, Show a) => EqProp (Extended a) where + NegInf =-= NegInf = property True + PosInf =-= PosInf = property True + (Finite x) =-= (Finite y) = x =-= y + x =-= y = counterexample (show x <> " /= " <> show y) False + instance Arbitrary Interval.Boundary where arbitrary = elements [ Interval.Open , Interval.Closed ] @@ -384,3 +424,60 @@ instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where Interval.interval lower upper + +instance CoArbitrary a => CoArbitrary (Interval a) where + coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int) + +instance (Function a, Ord a) => Function (Interval a) where + function = functionMap g h + where + g = lowerBound' &&& upperBound' + h = uncurry interval + +deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a)) + +instance ToJSON a => ToJSON (Interval a) where + toJSON x = Array . fromList $ + [ object [ lowerKey .= lowerVal ] + , object [ upperKey .= upperVal ] + ] + where + (lowerVal, lowerBoundary) = lowerBound' x + (upperVal, upperBoundary) = upperBound' x + upperKey = boundaryToKey upperBoundary + lowerKey = boundaryToKey lowerBoundary + boundaryToKey Open = "Excluded" + boundaryToKey Closed = "Included" + +instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where + parseJSON x = + boundPairWithBoundary x + <|> boundPairWithoutBoundary x + <|> singleVal x + where + boundPairWithBoundary = withArray "Bound pair" $ \arr -> do + checkLength arr + lower <- parseBound $ arr ^?! ix 0 + upper <- parseBound $ arr ^?! ix 1 + pure $ interval lower upper + parseBound = withObject "Bound" $ \obj -> do + when (length obj /= 1) $ fail "Expected an object with a single key" + let [(k, v)] = obj ^@.. ifolded + boundary <- case k of + "Excluded" -> pure Open + "Open" -> pure Open + "Included" -> pure Closed + "Closed" -> pure Closed + _ -> fail "Invalid boundary specification" + val <- parseJSON v + pure (val, boundary) + boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do + checkLength arr + lower <- parseJSON $ arr ^?! ix 0 + upper <- parseJSON $ arr ^?! ix 1 + pure $ lower <=..< upper + singleVal v = do + val <- parseJSON v + pure $ val <=..<= val + checkLength arr = + when (length arr /= 2) $ fail "Expected array of length 2" |