mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 11:17:08 +03:00
add prototype of a new rouge level generator
This commit is contained in:
parent
7c1c7894ab
commit
8237c57123
132
test/RougeStory.hs
Normal file
132
test/RougeStory.hs
Normal file
@ -0,0 +1,132 @@
|
|||||||
|
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||||
|
module RougeStory where
|
||||||
|
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
|
import Graphics.Vty
|
||||||
|
import Graphics.Vty.Inline
|
||||||
|
|
||||||
|
-- Characters are identified by Names
|
||||||
|
type Character = Name
|
||||||
|
type Name = String
|
||||||
|
type Type = String
|
||||||
|
|
||||||
|
-- The game is the view of a story.
|
||||||
|
class Story repr where
|
||||||
|
-- A story is the quest of a character which becomes a history
|
||||||
|
story :: Character -> repr Quest -> repr History
|
||||||
|
quest :: repr Goal -> repr Aspects -> repr Quest
|
||||||
|
|
||||||
|
-- A quest is for a goal where some aspects are known and others unknown.
|
||||||
|
-- TODO: abstract to any Foldable?
|
||||||
|
empty_aspects :: repr Aspects
|
||||||
|
add_known_history :: repr History -> repr Aspects -> repr Aspects
|
||||||
|
add_known_obj :: repr Object -> repr Aspects -> repr Aspects
|
||||||
|
add_unknown_history :: repr History -> repr Aspects -> repr Aspects
|
||||||
|
add_unknown_obj :: repr Object -> repr Aspects -> repr Aspects
|
||||||
|
|
||||||
|
-- Aspects are animate objects, inanimate objects or histories.
|
||||||
|
animate_obj :: Type -> repr Object
|
||||||
|
inanimate_obj :: Type -> repr Object
|
||||||
|
history :: Type -> repr History
|
||||||
|
|
||||||
|
-- The goal is to acquire, or dispose of an object.
|
||||||
|
dispose_obj :: repr Object -> repr Goal
|
||||||
|
acquire_obj :: repr Object -> repr Goal
|
||||||
|
|
||||||
|
-- What is an object? Well, that's anything that fits in the story language.
|
||||||
|
-- Which at least means it's something that can be named
|
||||||
|
named :: repr Object -> Name -> repr Object
|
||||||
|
|
||||||
|
data Quest
|
||||||
|
data History
|
||||||
|
data Goal
|
||||||
|
data Aspects
|
||||||
|
data Object
|
||||||
|
|
||||||
|
story_0 =
|
||||||
|
let bob = animate_obj "Human" `named` "Bob"
|
||||||
|
the_quest = quest (dispose_obj (inanimate_obj "YoYo" `named` "The Kitten Slayer"))
|
||||||
|
(add_known_obj bob empty_aspects)
|
||||||
|
in story "Bob" the_quest
|
||||||
|
|
||||||
|
{- TEMPLATE
|
||||||
|
instance Story X where
|
||||||
|
story c q =
|
||||||
|
quest g as =
|
||||||
|
empty_aspects =
|
||||||
|
add_known_history h as =
|
||||||
|
add_known_obj obj as =
|
||||||
|
add_unknown_history h as =
|
||||||
|
add_unknown_obj obj as =
|
||||||
|
animate_obj t =
|
||||||
|
inanimate_obj t =
|
||||||
|
history t =
|
||||||
|
dispose_obj obj =
|
||||||
|
acquire_obj obj =
|
||||||
|
named obj n =
|
||||||
|
-}
|
||||||
|
|
||||||
|
newtype ShowStory t = ShowStory { unShowStory :: String }
|
||||||
|
instance Story ShowStory where
|
||||||
|
story c q = ShowStory $ printf "History(%s,%s)" c (unShowStory q)
|
||||||
|
quest g as = ShowStory $ printf "Quest(%s,%s)" (unShowStory g) (unShowStory as)
|
||||||
|
empty_aspects = ShowStory $ printf "EmptyAspects"
|
||||||
|
add_known_history h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)
|
||||||
|
add_known_obj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)
|
||||||
|
add_unknown_history h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)
|
||||||
|
add_unknown_obj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)
|
||||||
|
animate_obj t = ShowStory $ printf "%s :: AnimateObj" t
|
||||||
|
inanimate_obj t = ShowStory $ printf "%s :: InanimateObj" t
|
||||||
|
history t = ShowStory $ printf "%s :: History" t
|
||||||
|
dispose_obj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)
|
||||||
|
acquire_obj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)
|
||||||
|
named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)
|
||||||
|
|
||||||
|
newtype TellStory t = TellStory { unTellStory :: String }
|
||||||
|
|
||||||
|
instance Story TellStory where
|
||||||
|
story c (TellStory quest) = TellStory $ "The story of " ++ c ++ " on the quest " ++ quest
|
||||||
|
quest (TellStory g) (TellStory as)
|
||||||
|
| as == "" = TellStory $ g ++ "."
|
||||||
|
| otherwise = TellStory $ g ++ ". In a world where... " ++ as
|
||||||
|
empty_aspects = TellStory ""
|
||||||
|
add_known_history (TellStory h) (TellStory as)
|
||||||
|
= TellStory $ "Our hero knows the tale of\n\t" ++ h ++ ".\n" ++ as
|
||||||
|
add_known_obj (TellStory obj) (TellStory as)
|
||||||
|
= TellStory $ "Our hero knows of " ++ obj ++ ". " ++ as
|
||||||
|
add_unknown_history _ as = as
|
||||||
|
add_unknown_obj _ as = as
|
||||||
|
animate_obj t = TellStory t
|
||||||
|
inanimate_obj t = TellStory t
|
||||||
|
history t = TellStory t
|
||||||
|
dispose_obj (TellStory obj)
|
||||||
|
= TellStory $ "to dispose of the accursed " ++ obj
|
||||||
|
acquire_obj (TellStory obj)
|
||||||
|
= TellStory $ "to acquire the great " ++ obj
|
||||||
|
named (TellStory obj) name
|
||||||
|
= TellStory $ obj ++ " with the name " ++ name
|
||||||
|
|
||||||
|
newtype PictureStory t = PictureStory { compose_to_picture :: Picture }
|
||||||
|
|
||||||
|
{-
|
||||||
|
instance Story X where
|
||||||
|
story c q =
|
||||||
|
quest g as =
|
||||||
|
empty_aspects =
|
||||||
|
add_known_history h as =
|
||||||
|
add_known_obj obj as =
|
||||||
|
add_unknown_history h as =
|
||||||
|
add_unknown_obj obj as =
|
||||||
|
animate_obj t =
|
||||||
|
inanimate_obj t =
|
||||||
|
history t =
|
||||||
|
dispose_obj obj =
|
||||||
|
acquire_obj obj =
|
||||||
|
named obj n =
|
||||||
|
-}
|
||||||
|
|
||||||
|
main = do
|
||||||
|
putStrLn $ unTellStory story_0
|
||||||
|
putStrLn $ unShowStory story_0
|
||||||
|
withVty $ flip update (compose_to_picture story_0)
|
Loading…
Reference in New Issue
Block a user