Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Minimum Sum of All Travel Times

By: a guest on Feb 20th, 2012  |  syntax: Haskell  |  size: 2.74 KB  |  hits: 184  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
This paste has a previous version, view the difference. Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. module Main where
  2. import Data.List
  3. import Data.Ord
  4.  
  5. -- For testing purpose
  6. import Test.QuickCheck
  7. import Test.QuickCheck.Gen
  8. import System.Random
  9.  
  10. type Z  = Integer
  11. type Pt = (Z,Z)
  12. type Dir = Pt
  13. type Cost = Z
  14.  
  15. sumV :: [Pt] -> Pt
  16. sumV = foldr addV (0,0)
  17.  
  18. addV :: Pt -> Pt -> Pt
  19. addV (x,y) (u,v) = (x+u,y+v)
  20.  
  21. divV :: Pt -> Z -> Pt
  22. divV (x,y) d = (x `div` d,y `div` d)
  23.  
  24. second :: (a,b,c) -> b
  25. second (_,y,_) = y
  26.  
  27. third :: (a,b,c) -> c
  28. third (_,_,z) = z
  29.  
  30. mean :: [Pt] -> Pt
  31. mean xs = sumV xs `divV` genericLength xs
  32.  
  33. dir0 :: [Dir]
  34. dir0 = [(-1,1) ,(0,1) ,(1,1)
  35.        ,(-1,0)        ,(1,0)
  36.        ,(-1,-1),(0,-1),(1,-1)]
  37.  
  38. -- Tweaking this would result 2x speed-up
  39. restrict :: Dir -> [Dir] -> [Dir]
  40. restrict d ds = ds
  41.  
  42. d :: Pt -> Pt -> Z
  43. d (x,y) (u,v) = max (abs (x-u)) (abs (y-v))
  44.  
  45. costAt :: [Pt] -> Pt -> Cost
  46. costAt xs p = sum $ map (d p) xs
  47.  
  48. cand :: Pt -> [Dir] -> [Pt]
  49. cand p ds = map (addV p) ds
  50.  
  51. step :: [Pt] -> (Pt,Cost,[Dir]) -> (Pt,Cost,[Dir])
  52. step xs (p,c,ds)
  53.     |  c' < c    =  (p',c', restrict d ds)
  54.     |  otherwise =  (p ,c , [])
  55.     where
  56.       (p',c',d) = minimumBy (comparing second) $ map (look xs p) ds
  57.  
  58. look :: [Pt] -> Pt -> Dir -> (Pt,Cost,Dir)
  59. look xs p d = (p',costAt xs p',d)
  60.     where p' = p `addV` d
  61.  
  62. -- seems like a reasonable guess
  63. start :: [Pt] -> (Pt,Cost,[Dir])
  64. start xs = (p0,c0,dir0)
  65.     where
  66.       p0  = mean xs
  67.       c0  = costAt xs p0
  68.            
  69.  
  70. opt :: [Pt] -> (Pt,Cost,[Dir])
  71. opt xs =  head $ dropWhile (not . null . third) $ iterate (step xs) $ start xs
  72.  
  73. optDebug :: [Pt] -> (Bool,[(Pt,Cost,[Dir])])
  74. optDebug xs =  (check xs p,head ns : ms)
  75.     where
  76.       (ms,ns) = span (not . null . third) $ iterate (step xs) $ start xs
  77.       (p,c,_) = head ns
  78. -------------------------------------------------
  79. -- test code
  80. -------------------------------------------------
  81.  
  82. check :: [Pt] -> Pt -> Bool
  83. check xs p = costAt xs p <= minimum (map (costAt xs) (cand p dir0))
  84.  
  85. prop_opt :: [Pt] -> Bool
  86. prop_opt xs = let (p,c,_) = opt xs
  87.               in check xs p
  88.  
  89. rollDice :: IO Int
  90. rollDice = getStdRandom random
  91.  
  92. randomPts :: Int -> IO [Pt]
  93. randomPts n = do rollDice
  94.                  gen <- getStdGen
  95.                  return $ unGen (vectorOf n arbitrary) gen 1000
  96.  
  97. main = do xs <- randomPts 100000
  98.           print $ optDebug xs
  99.  
  100. sample0,sample1,sample2 :: [Pt]
  101. sample0 = [(0,0)]
  102. sample1 = [(0,0),(1,1)]
  103. sample2 = [(0,2),(1,2),(2,2)
  104.           ,      (1,1)
  105.           ,            (2,0) ]
  106.  
  107. sample3 = [(0,3)
  108.           ,(0,2),(1,2)
  109.           ,(0,1),(1,1),(2,1)
  110.           ,(0,0),(1,0),(2,0),(3,0)]
  111.  
  112.  
  113. sample4 = [(0,3)
  114.           ,(0,2),(1,2)
  115.           ,(0,1),(1,1),(2,1)
  116.           ,(0,0),(1,0),(2,0),(3,0)]
  117.  
  118. sample5 = [ (-3, 0), (-2, 0), (-1, 0), (0, 0), (10, 0), (50, 0) ]
create a new version of this paste RAW Paste Data