1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15
16. 16
17. 17
18. 18
19. 19
20. 20
21. 21
22. 22
23. 23
24. 24
25. 25
26. 26
27. 27
28. 28
29. 29
30. 30
31. 31
32. 32
33. 33
34. 34
35. 35
36. 36
37. 37
38. 38
39. 39
40. 40
41. 41
42. 42

instance Arbitrary ProjectConfig where
    arbitrary =
      ProjectConfig
        <$> (map getPackageLocationString <$> arbitrary)
        <*> (map getPackageLocationString <$> arbitrary)
        <*> shortListOf 3 arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> (MapMappend . fmap getNonMEmpty . Map.fromList
               <$> shortListOf 3 arbitrary)
        -- package entries with no content are equivalent to
        -- the entry not existing at all, so exclude empty

    shrink ProjectConfig { projectPackages = x0
                         , projectPackagesOptional = x1
                         , projectPackagesRepo = x2
                         , projectPackagesNamed = x3
                         , projectConfigBuildOnly = x4
                         , projectConfigShared = x5
                         , projectConfigProvenance = x6
                         , projectConfigLocalPackages = x7
                         , projectConfigSpecificPackage = x8
                         , projectConfigAllPackages = x9 } =
      [ ProjectConfig { projectPackages = x0'
                      , projectPackagesOptional = x1'
                      , projectPackagesRepo = x2'
                      , projectPackagesNamed = x3'
                      , projectConfigBuildOnly = x4'
                      , projectConfigShared = x5'
                      , projectConfigProvenance = x6'
                      , projectConfigLocalPackages = x7'
                      , projectConfigSpecificPackage = (MapMappend
                                                         (fmap getNonMEmpty x8'))
                      , projectConfigAllPackages = x9' }
      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9'))
          <- shrink ((x0, x1, x2, x3),
                      (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9))
      ]

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7

data Foo a = Foo {a :: a, b :: Int}
           | Bar {b :: Int}

foo :: (a -> b) -> Foo a -> Foo b
foo f <a href="/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="156d55537a7a">[email protected]</a>{a = a} = x{a = f a}
foo _ <a href="/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="c9b1898ba8bb">[email protected]</a>{} = x   -- error: Couldn't match type ‘a’ with ‘b’
foo _ <a href="/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="4830080a293a">[email protected]</a>{} = x{} -- error: Empty record update

1. 1
2. 2
3. 3
4. 4
5. 5

-- https://haskell-lang.org/library/http-client
let request = setRequestBodyFile "people.yaml"
            $ setRequestHeader "Content-Type" ["application/x-yaml"]
            $ "PUT https://httpbin.org/put"
response <- httpJSON request

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15
16. 16
17. 17
18. 18
19. 19
20. 20
21. 21
22. 22
23. 23
24. 24
25. 25
26. 26
27. 27
28. 28
29. 29
30. 30
31. 31
32. 32
33. 33
34. 34
35. 35

topSort :: V.Vector ([Int], [Int])
       -> Either String [Int]
topSort kob =
  let
    sup u k = do
      let max i = (i,) . head . snd <$> k `MV.read` i
      l <- mapM max u
      case filter (uncurry (==)) l of
        [(a,_)] -> return $ Right a
        x -> return $ Left "Topology error"

    rewrite k s (i, j) = do
      let f x | x == s && j < 0 = []
              | x == s = [j]
              | otherwise = [x]
      when (j>=0) $ MV.modify k (_1 %~ (i:)) j
      MV.modify k (_2 %~ (>>= f)) i

    go u k =
      readSTRef u >>= \case
        [a] -> return $ Right [a]
        u_ -> sup u_ k >>= \case
          Right s -> do
            modifySTRef' u $ Data.List.delete s
            s_d <- fst <$> MV.read k s
            mapM_ (rewrite k s) $ zip s_d (tail s_d ++ [-1])
            tail <- go u k
            return $ (s:) <$> tail
          Left err ->
            return  $ Left err

  in runST $ do
    u <- newSTRef $ [0..V.length kob-1]
    k <- V.thaw kob
    liftM reverse <$> go u k

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6

sign' ← case sign of
            '-' → return '-'
            '+' → return ' '
            _   → Nothing
  hh ← (readMaybe [sign',h1,h2]) :: Maybe Integer
  mm ← (readMaybe mm) :: Maybe Integer

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15
16. 16
17. 17
18. 18
19. 19
20. 20
21. 21
22. 22
23. 23
24. 24
25. 25
26. 26
27. 27
28. 28
29. 29
30. 30
31. 31
32. 32

-- GUESS THE NAME OF "algorithmX":
import qualified Data.List as DL
infinity = 1/0
adjacencyMatrix =
  [[0,3,1,6,0,0],
   [3,0,5,0,3,0],
   [1,5,0,5,6,4],
   [6,0,5,0,0,2],
   [0,3,6,0,0,6],
   [0,0,4,2,6,0]] :: [[Double]]

replaceZerosWithInfinity matrix =
  map (map (\e -> if e == 0 then infinity else e)) matrix

type Edge = (Int,Int,Double)

algorithmX adjacencyMatrix initialVertex = (minimumTotalCost,minimumEdges)
  where
    third (_,_,t) = t
    minimumTotalCost = sum $ map third minimumEdges
    (_,minimumEdges) = foldl iterate ([initialVertex],[]) [1..n-1]
    matrix = replaceZerosWithInfinity adjacencyMatrix
    n = length matrix
    getIndexes visited =
      filter (\(i,j) -> not $ elem j visited) [(i,j) | i <- visited, j <- [0..n-1]]
    iterate :: ([Int],[Edge]) -> Int -> ([Int],[Edge])
    iterate (visited,edges) iteration = (newVisited:visited,minimumEdge:edges)
      where
        (_,newVisited,_) = minimumEdge 
        minimumEdge = DL.minimumBy compareEdges $ map newEdge (getIndexes visited)
        newEdge (i,j) = (i,j,matrix !! i !! j)
        compareEdges e0 e1 = compare (third e0) (third e1)

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13

███████                                                                                                                         
██   ██                                                                                                                         
██   ██                                                                                                                         
██   ██  █████     ████ ██   ██ ██████  █████  ██████  ████        ██   ██  █████       ██   ██ ██   ██ ██ █ ██ ██   ██  ████   
██   ██ ██   ██   ██ ██ ██   ██ █ ██ █ ██   ██ █ ██ █     ██       ██   ██ ██   ██      ██   ██ ██   ██ ██ █ ██ ██   ██     ██  
██   ██ ██   ██  ██  ██ ██  ███   ██   ██   ██   ██    █████       ██   ██ ██   ██      ██   ██ ██   ██  █ █ █  ██   ██  █████  
██   ██ ██   ██  ██  ██ ██ █ ██   ██   ██   ██   ██   ██  ██       ███████ ███████      ███████ ██   ██  █████  ███████ ██  ██  
██   ██ ██   ██  ██  ██ ███  ██   ██   ██   ██   ██   ██  ██       ██   ██ ██           ██   ██ ██   ██  █ █ █  ██   ██ ██  ██  
██   ██ ██   ██  ██  ██ ██   ██   ██   ██   ██   ██   ██  ██       ██   ██ ██   ██      ██   ██  ██████ ██ █ ██ ██   ██ ██  ██  
██   ██  █████  ███  ██ ██   ██  ████   █████   ████   ███ ██      ██   ██  █████       ██   ██      ██ ██ █ ██ ██   ██  ███ ██ 
                                                                                                     ██                         
                                                                                                ██   ██                         
                                                                                                 █████

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15
16. 16
17. 17
18. 18
19. 19
20. 20
21. 21
22. 22
23. 23
24. 24
25. 25
26. 26
27. 27
28. 28
29. 29
30. 30
31. 31
32. 32
33. 33
34. 34
35. 35
36. 36
37. 37
38. 38
39. 39
40. 40
41. 41
42. 42
43. 43
44. 44
45. 45
46. 46
47. 47
48. 48
49. 49
50. 50
51. 51
52. 52
53. 53
54. 54
55. 55
56. 56
57. 57
58. 58
59. 59
60. 60
61. 61
62. 62

kobenate :: (MonadVoretion m)
         => Config
         -> Disjunct
         -> RuleZipper
         -> m Disjunct
kobenate cfg d₀ z = uphill d₀ z 
  where
    climb t x =
      case parent x of
        Just x' -> uphill t x'
        Nothing -> return t

    uphill t x =
      case label <$> parent x of
        Just (LinkAnd{}) -> do
          i <- downhill' cfg $ reverse $ before x
          j <- downhill' cfg $ after x
          climb (i \++/ t \++/ j) x
        _ ->
          case label x of
            MultiConnector{} -> do
              m <- downhill cfg (tree x)
              let t' = t \++/ m
              climb t' x
            _ ->
              climb t x

downhill' :: (MonadVoretion m)
          => Config
          -> [Link]
          -> m Disjunct
downhill' cfg x = foldl (\++/) ([], []) <$> mapM (downhill cfg) x

downhill :: (MonadVoretion m)
         => Config
         -> Link
         -> m Disjunct
downhill cfg <a href="/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="1b772b5b">[email protected]</a>(Node label subforest) =
  case label of
    Optional _ ->
      ifR (_decay_optional cfg)
         {-then-} (downhill cfg $ head subforest)
         {-else-} (return ([], []))
    MultiConnector _ ->
      ifR (_decay_multi cfg)
         {-then-} (do
           a <- downhill cfg l0
           b <- downhill cfg $ head subforest
           return $ a \++/ b)
         {-else-} (return ([], []))
    LinkOr{} ->
      downhill cfg =<< pickRandom subforest
    LinkAnd{} ->
      downhill' cfg subforest
    Cost{} ->
      downhill' cfg subforest
    EmptyLink ->
      return ([], [])
    Link{_link=i} -> do
      case _linkDirection i of
        Plus  -> return ([], [Left i])
        Minus -> return ([Left i], [])

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15

findConnections :: LinkID
                -> Link
                -> [RuleZipper]
findConnections x = go . fromTree
  where go z =
          case label z of
            Link {_link=l}
              | x' =*= l -> [z]
              | True     -> []
            _ ->
              go' (firstChild z) ++ go' (next z)

        go' x = (toList x) >>= go

        x' = flipLink x

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10
11. 11
12. 12
13. 13
14. 14
15. 15
16. 16
17. 17
18. 18
19. 19
20. 20
21. 21

-- | @'resetT' m@ delimits the continuation of any 'shiftT' inside @m@.
--
-- * @'resetT' ('lift' m) = 'lift' m@
--
resetT :: (Monad m) => ContT r m r -> ContT r' m r
resetT = lift . evalContT
{-# INLINE resetT #-}

-- | @'shiftT' f@ captures the continuation up to the nearest enclosing
-- 'resetT' and passes it to @f@:
--
-- * @'resetT' ('shiftT' f >>= k) = 'resetT' (f ('evalContT' . k))@
--
shiftT :: (Monad m) => ((a -> m r) -> ContT r m r) -> ContT r m a
shiftT f = ContT (evalContT . f)
{-# INLINE shiftT #-}

.... Usage:

Prelude Control.Monad.Trans.Cont> evalCont $ callCC (\done -> reset (done "Ok") >> return "Fuck you!" )
"Fuck you!"