Admin: 1 версия импортирована

2023-02-27T18:39:15Z

1 версия импортирована

← Предыдущая версия	Версия от 21:39, 27 февраля 2023
(нет различий)

lor>Cetjs2: Откат правок 163.172.227.165 (обсуждение) к версии Cetjs2

2018-05-13T08:32:51Z

Откат правок 163.172.227.165 (обсуждение) к версии Cetjs2

Новая страница

Вся программа в одном файле.

<pre>
module Main where

import Data.Map hiding (map, filter, delete, null)
import Data.List
import System.IO

data Point = Point {
x:: Int,
y:: Int }
deriving (Eq, Ord)

toUp (Point x y) = Point x (y + 1)
toDown (Point x y) = Point x (y - 1)
toLeft (Point x y) = Point (x + 1) y
toRight (Point x y) = Point (x - 1) y

data World = World
{ sizex:: Int,
sizey:: Int,
walls:: [Point],
items:: [Point],
player:: Point,
carry:: Bool
}

readWorld y [] = World 0 (y - 1) [] [] (Point 0 0) False
readWorld y (line:rest) = readLine (readWorld (y + 1) rest) 1 line
where
readLine world x [] = world { sizex = max x (sizex world) }
readLine world x (cell:rest) =
readLine readCell (x + 1) rest
where
readCell =
world {
walls = if cell == '#' then point:worldWalls else worldWalls,
items = if cell == '.' then point:worldItems else worldItems,
player = if cell == '@' then point else (player world) }
where
point = Point x y
worldWalls = walls world
worldItems = items world

getWorld = do
worldStream <- readFile "data"
return (readWorld 1 $ lines worldStream)

showWorld _ 0 = []
showWorld world y = (showLine (Point (sizex world) y)) : showWorld world (y - 1)
where
showLine (Point 0 _) = []
showLine point = showCell : showLine (toRight point)
where
showCell
| point `elem` (walls world) = '#'
| point == (player world) = '@'
| point `elem` (items world) = '.'
| otherwise = ' '

isValid world point@(Point x y) =
point `notElem` (walls world) &&
x>0 && x<=(sizex world) &&
y>0 && y<=(sizey world)

bringAll world =
foldr (++) [] (map bringItem $ items world)
where
start = player world
neighbours point = [dir point |
dir <- [toUp, toDown, toLeft, toRight],
isValid world (dir point) ]
waveMap [] wave = wave
waveMap front wave =
let source = head front
nb = filter (`notMember` wave) $ neighbours source
g = wave ! source + 1 in
waveMap (tail front ++ nb)
(foldr
(\point wm -> insertWith (\_ n -> n) point g wm)
wave nb)
waveMap' = waveMap [start] (singleton start 0)
bringItem item =
(traceProgram $ reverse itemTrace) ++ ["take"] ++ traceProgram itemTrace ++ ["drop"]
where
itemTrace = trace item
trace item
| start == item = [item]
| otherwise = item : trace nearest
where
nearest = minimumBy genOrder $ neighbours item
where
findGen p = findWithDefault (waveMap' ! item) p waveMap'
genOrder p1 p2 = compare (findGen p1) (findGen p2)
traceProgram [point] = []
traceProgram (point:rest) = (command point (head rest)):(traceProgram rest)
where
command (Point x1 y1) (Point x2 y2) =
case Point (x2-x1) (y2-y1) of
Point 0 1 -> "up"
Point 0 (-1) -> "down"
Point 1 0 -> "left"
Point (-1) 0 -> "right"

getProgram = do
str <- getLine
return (words str)

applyProgram program world initial =
foldl applyCommand world program
where
applyCommand world str =
case str of
"up" -> step toUp
"down" -> step toDown
"left" -> step toLeft
"right" -> step toRight
"take" -> grab True delete
"drop" -> grab False (:)
"reset" -> initial
"collect" -> applyProgram (bringAll world) world initial
otherwise -> world
where
current = player world
step dir
| isValid world target = world { player = target }
| otherwise = world
where
target = dir current
grab carryFlag action
| carry world == carryFlag = world
| otherwise = world { carry=carryFlag,
items=action current (items world) }

doRepl world initial = do
putStr (unlines $ showWorld world (sizey world))
program <- getProgram
if null program
then
return ()
else
doRepl (applyProgram program world initial) initial

main = do
world <- getWorld
doRepl world world
</pre>

[[Category:LOR-contest]]

LOR-contest/Haskell - История изменений

Admin: 1 версия импортирована

lor>Cetjs2: Откат правок 163.172.227.165 (обсуждение) к версии Cetjs2