Nexus + Zipper Elevator Problem

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
-- http://www.reddit.com/r/haskell/comments/1rbnst/i_made_a_so_question_about_solving_dynamic/
-- I wanted to try the nexus-approach with a zipper for performance!
{-# LANGUAGE NoMonomorphismRestriction #-}
module Elevator where
import Control.Applicative

data Floor = Floor { name :: Int, goUp :: Floor, goDown :: Floor }
  deriving Show

allFloors :: [Floor]
allFloors = map create [0..]
  where create i = Floor i (allFloors !! (i + 2)) (allFloors !! (i - 3))
-- OK, but it doesn't work that well because (!!) is very costy.

data Zipper a = Zipper { left :: [a], right :: [a] }
current   (Zipper _ (c:_))   = c
moveLeft  (Zipper (l:ls) rs) = Zipper ls (l:rs)
moveRight (Zipper ls (r:rs)) = Zipper (r:ls) rs
-- HACK! The current focused element of the zipper in the right list.
-- This means that we have the relative floors index
--        [..., -3, -2, -1] [0, 1, 2, ...]

allFloorsZ :: [Floor]
allFloorsZ = right zs
  where zs :: Zipper Floor
        zs = Zipper (go moveLeft [-1,-2..]) (go moveRight [0,1..])
        go move names = zipWith create names $ iterate move zs
        create :: Int -> Zipper Floor -> Floor
        create i z = Floor i (right z !! 2) (left z !! 2)
--                                                     ^ because of the zipper unbalance, not 3

-- The problem with nexuses is that sharing is unexploitable as soon as the structure is built.

data Floor' a = Floor' { value' :: a, name' :: Int, goUp' :: Floor' a, goDown' :: Floor' a }
  deriving Show

allFloorsZ' :: (Floor' a -> a) -> [Floor' a]
allFloorsZ' valueOf = right zs
  where zs = Zipper (go moveLeft [-1,-2..]) (go moveRight [0,1..])
        go move names = zipWith create names $ iterate move zs
        create i z = f where f = Floor' (valueOf f) i (right z !! 2) (left z !! 2)

data Nat = Zero | Succ Nat
natMin Zero _ = Zero
natMin _ Zero = Zero
natMin (Succ a) (Succ b) = Succ $ natMin a b

toInt Zero = 0
toInt (Succ n) = 1 + toInt n

minFloor i floor | i == name' floor = Zero
                 | otherwise = Succ $ natMin (value' $ goUp' floor) (value' $ goDown' floor)

minimalDistanceToFloor :: Int -> [Int]
minimalDistanceToFloor = map (toInt . value') . allFloorsZ' . minFloor