Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
188 lines (152 sloc) 8.41 KB
module Objects where
import Types
import Tools
import Text.Printf(printf)
import qualified Data.List as L
--- Data functions ---
homePhone1 = Object "Digital Phone" NoRoom
homePhone2 = Object "Broken Phone" NoRoom
homeTable = Object "Table" NoRoom
homeUmbrella1 = Object "Red Umbrella" NoRoom
homeUmbrella2 = Object "Blue Umbrella" NoRoom
rope = Object "Rope" NoRoom
homeHook = Object "Hook" NoRoom
ropeOnHook = Complex "Rope on hook" rope homeHook NoRoom
homeLighter = Object "Lighter" NoRoom
homeDiary = Object "Diary" NoRoom
homeDrawer = Container "Drawer" Closed [homeDiary, homeLighter] NoRoom
bag = Container "Bag" Opened [] InventoryRoom
objectDescription' :: Object -> String
objectDescription' obj | obj == homeUmbrella1 = "Nice red mechanic Umbrella."
| obj == homeUmbrella2 = "Nice blue Umbrella."
| obj == homePhone1 = "The Phone has some voice messages for you."
| obj == homePhone2 = "Broken electric phone."
| obj == rope = "Good 30 meters rope."
| obj == homeHook = "Massive steel hook nailed to wall."
| obj == homeTable = "Good wooden table with drawer."
| obj == homeDiary = "Your diary."
| obj == ropeOnHook = "Rope on hook looks tight."
| otherwise = printf "There is nothing special about %s." (showObject obj)
objectPickupFailMessage' :: Object -> String
objectPickupFailMessage' obj | obj == homePhone1 = "Phone drawes a wires and strikes against the table!"
| otherwise = printf "You can't take a %s." (showObject obj)
isPickupable :: Object -> Bool
isPickupable obj = obj `elem` [homeUmbrella1, rope]
wld1 (obj1:obj2:[]) | obj1 == rope && obj2 == homeHook = Just (ropeOnHook, "You successfully tied rope to the hook.")
wld1 _ = Nothing
welders :: [Welder]
welders = [wld1]
(<|>) :: Welder -> Welder -> Welder
w1 <|> w2 = \os -> let perm = L.permutations os in
case filter (/= Nothing) (map w1 perm) of
[] -> case filter (/= Nothing) (map w2 perm) of
[] -> Nothing
(x:_) -> x
(y:_) -> y
----------------------
isContainer :: Object -> Bool
isContainer (Container _ _ _ _) = True
isContainer _ = False
readObject' :: [String] -> [String] -> Bool
readObject' [] _ = False
readObject' _ [] = False
readObject' (x:xs) oNs = (any (== x) oNs) || readObject' xs oNs
readObject :: String -> Objects -> Objects
readObject [] _ = []
readObject _ [] = []
readObject str (o:os) = case readObject' (words str) ((words . objectName) o) of
True -> o : readObject str os
False -> readObject str os
-- Ôóíêöèÿ ýêâèâàëåíòíîñòè. Ïîçâîëÿåò ñðàâíèâàòü îáúåêòû ïî èõ ÷àñòè÷íîìó ñîâïàäåíèþ.
(=|=) :: Object -> Object -> Bool
Complex _ x1 x2 _ =|= o@(Object _ _) = x1 == o || x2 == o
o@(Object _ _) =|= Complex _ y1 y2 _ = y1 == o || y2 == o
x =|= y = x == y
matchedObjects :: Object -> Objects -> Objects
matchedObjects _ [] = []
matchedObjects obj objects = filter (=|= obj) objects
replaceObject :: Object -> Objects -> Objects
replaceObject obj objects = obj : [newObj | newObj <- objects, newObj /= obj]
replaceObjectList :: Objects -> Objects -> Objects
replaceObjectList [] _ = []
replaceObjectList _ [] = []
replaceObjectList (n:ns) objects = replaceObjectList ns (replaceObject n objects)
pickup :: Object -> (Maybe Object, String)
pickup obj | objectRoom obj == InventoryRoom = (Nothing, objectAlreadyInInventoryError obj)
| otherwise = case isPickupable obj of
True -> (Just (obj {objectRoom = InventoryRoom}), successPickupingObjectMsg obj)
False -> (Nothing, failurePickupingObjectMsg obj)
weld :: Object -> Object -> MaybeWeldedObject
weld o1 o2 = (foldr1 (<|>) welders) [o1, o2]
roomObjects :: Room -> Objects -> [Object]
roomObjects room = filter (\x -> objectRoom x == room)
----------- Messages, Errors ------------
-- f :: Object -> String
notVisibleObjectError obj = printf "You don't see any %s here." (showObject obj)
cannotBeOpenedError obj = printf "The %s cannot be opened." (showObject obj)
cannotBeClosedError obj = printf "The %s cannot be closed." (showObject obj)
alreadyOpenError obj = printf "%s already opened." (showObject obj)
alreadyCloseError obj = printf "%s already closed." (showObject obj)
successPickupingObjectMsg obj = printf "%s added to your inventory." (showObject obj)
failurePickupingObjectMsg = objectPickupFailMessage'
objectAlreadyInInventoryError obj = printf "You already have a %s." (showObject obj)
failureWeldObjectsError o1 o2 = printf "You can't weld %s to %s." (showObject o1) (showObject o2)
successOpeningObjectMsg :: Object -> Objects -> String
successOpeningObjectMsg obj [] = "Opened."
successOpeningObjectMsg obj (o:[]) = printf "Opening %s reveals %s." (showObject obj) (showObject o)
successOpeningObjectMsg obj os = describeObjects (printf "Opening %s reveals some objects: " (showObject obj)) os
instance Openable Object where
open obj@(Container _ Opened _ _) = (Nothing, alreadyOpenError obj)
open obj@(Container _ Closed _ _) = (Just $ obj {objectContainerState = Opened}, successOpeningObjectMsg obj (objectContents obj))
open obj = (Nothing, cannotBeOpenedError obj)
close obj@(Container _ Opened _ _) = (Just $ obj {objectContainerState = Closed}, "Closed.")
close obj@(Container _ Closed _ _) = (Nothing, alreadyCloseError obj)
close obj = (Nothing, cannotBeClosedError obj)
showStated obj@(Container _ Opened _ _) = "(opened) " ++ showObject obj
showStated obj = showObject obj
showContents obj@(Container _ Opened cont@(x:xs) _) = describeObjects (printf "\nThe %s contains " (showObject obj)) cont
showContents _ = []
instance Eq Object where
o1 == o2 = objectName o1 == objectName o2
----------------------- Ôóíêöèè îòîáðàæåíèÿ îáúåêòà è ñïèñêà îáúåêòîâ. ---------------------------
type ObjectShowPrefix = (String, String)
type IntroString = String
type ShowObjectsFunc = ((Object -> Int -> String), (Int -> Int), Int)
type ShowObjectsBoundStrings = [String]
-- Âñïîìîãàòåëüíûå ôóíêöèè
showLeftBracket :: ShowObjectsBoundStrings -> String
showRightBracket :: ShowObjectsBoundStrings -> String
showDelimiter :: ShowObjectsBoundStrings -> String
showLeftBracket = head
showRightBracket = head . tail
showDelimiter = last
standartObjectShowingF :: ShowObjectsFunc
standartObjectShowingF = ((\x _ -> showStated x), \_ -> 0, 0)
standartBoundStrs :: ShowObjectsBoundStrings
standartBoundStrs = ["[", "].", ", "]
-- Âûâîäèò èíôîðìàöèþ îá îáúåêòå. Íå ïåðåêðûâàåò show, ÷òîáû îñòàâèòü âîçìîæíîñòü ñîõðàíÿòü äàííûå íà äèñê.
showObject :: Object -> String
showObject = objectName
applyObjectShowingF :: ShowObjectsFunc -> Object -> String
applyObjectShowingF (showingLambda, _, enumVal) obj = showingLambda obj enumVal
modifyObjectShowingF :: ShowObjectsFunc -> ShowObjectsFunc
modifyObjectShowingF (showingLambda, enumChangeF, enumVal) = (showingLambda, enumChangeF, enumChangeF enumVal)
showObjects :: ObjectShowPrefix -> ShowObjectsFunc -> ShowObjectsBoundStrings -> Objects -> String
showObjects pref _ _ [] = fst pref
showObjects pref lFuncDescr boundStrs xs = snd pref ++ (showLeftBracket boundStrs) ++ showObjects' xs lFuncDescr
where
showObjects' (x:[]) lFuncDescr = applyObjectShowingF lFuncDescr x ++ (showRightBracket boundStrs)
showObjects' (x:xs) lFuncDescr = applyObjectShowingF lFuncDescr x ++ (showDelimiter boundStrs) ++ showObjects' xs (modifyObjectShowingF lFuncDescr)
-- Ïåðå÷èñëÿåò îáúåêòû â âèäå [ñïèñêà]. Åñëè íå ïåðåäàíà ñòðîêà Intro, áóäåò ïîäñòàâëåíà ñòðîêà ïî óìîë÷àíèþ.
describeObjects :: IntroString -> Objects -> String
describeObjects [] os = (showObjects ([], "\nThere are some objects here: ") standartObjectShowingF standartBoundStrs os) ++ unwords(map showContents os)
describeObjects str os = (showObjects ([], str) standartObjectShowingF standartBoundStrs os) ++ unwords(map showContents os)
-- Ïîêàçûâàåò îñîáûå ñâîéñòâà îáúåêòîâ (åñëè îíè åñòü).
investigateObjects :: IntroString -> Objects -> String
investigateObjects str = showObjects ([], str) ((\x _ -> printf "\n%s: %s" (showObject x) (objectDescription' x)), \_ -> 0, 0) ["","",""]
-- Ïåðå÷èñëÿåò îáúåêòû èíâåíòàðÿ â âèäå [ñïèñêà]. Åñëè èíâåíòàðü ïóñò, òàê è ñîîáùàåò.
showInventory :: Objects -> String
showInventory os = showObjects ("No objects in your inventory.", "You have: ") standartObjectShowingF standartBoundStrs os
-- Ïåðå÷èñëÿåò îáúåêòû â âèäå ïðîíóìåðîâàííîãî ñïèñêà, íà÷èíàþùåãîñÿ ñ 0.
enumerateObjects :: IntroString -> Objects -> String
enumerateObjects str = showObjects ([], str) ((\x n -> printf "\n%d: %s" n (showObject x)), \y -> y + 1, 0) ["","",""]
Jump to Line
Something went wrong with that request. Please try again.