<commit_before><commit_msg>add prototype of a new rouge level generator<commit_after>{-# 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)
{'fraction_non_alphanumeric': 0.0917661847894406, 'fraction_numerical': 0.0008380473496752566, 'mean_word_length': 2.948717948717949, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 22, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4849253', 'n_tokens_mistral': 1602, 'n_tokens_neox': 1473, 'n_words': 547}