Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: redesign
Fetching contributors…

Cannot retrieve contributors at this time

188 lines (152 sloc) 8.608 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.