Ad
JohanWiltink

Generate valid TicTacToe boards in base 3

module Example (TicTacToe,empty,move) where

import Data.Set as Set (Set,fromList,toList)
import Data.List (elemIndices)

type TicTacToe = [Word] -- 9 × 0..2
type Player = Word

empty :: TicTacToe
empty = replicate 9 0

won :: Player -> TicTacToe -> Bool
won player board = any (all ((==) player . (!!) board))
                       [ [0,1,2], [3,4,5], [6,7,8], [0,3,6], [1,4,7], [2,5,8], [0,4,8], [2,4,6] ]

move :: Player -> Set TicTacToe -> Set TicTacToe
move player boards = Set.fromList $ concatMap move $ filter (not . won opponent) $ Set.toList boards where
  opponent | player == 1 = 2 | otherwise = 1
  move board = map ( \ p -> update p player board ) $ elemIndices 0 $ board

update :: Int -> Player -> TicTacToe -> TicTacToe
update p player board = left ++ player : right where (left,_:right) = splitAt p board
JohanWiltinkvs.JohanWiltink

Fibonacci with a list cache memoisation .hs

Code
Diff
  • module Example (fib) where

fibonacci :: [Integer]
fibonacci = 0 : scanl (+) 1 fibonacci

fib :: Int -> Integer
fib = (!!) fibonacci
    • module Example (fib,fibonacci) where
    • type RAList a = [ ( Int, Tree a ) ]
    • data Tree a = Empty | Node { here :: a, left, right :: Tree a } deriving ()
    • nil :: RAList a
    • nil = []
    • cons :: a -> RAList a -> RAList a
    • cons x ( (size0,tree0) : (size1,tree1) : trees ) | size0 == size1 = ( 1 + size0 + size1, Node x tree0 tree1 ) : trees
    • cons x trees = (1,Node x Empty Empty) : trees
    • fromListN :: Int -> [a] -> RAList a
    • fromListN n = foldr cons nil . take n
    • (!) :: RAList a -> Int -> a
    • ( (size,tree) : trees ) ! n | n < size = index tree size n | otherwise = trees ! (n - size) where
    • index tree size n | n == 0 = here tree
    • | n+n < size = index (left tree) (size `div` 2) (n-1)
    • | otherwise = index (right tree) (size `div` 2) (n-1 - size `div` 2)
    • module Example (fib) where
    • fibonacci :: [Integer]
    • fibonacci = 0 : scanl (+) 1 fibonacci
    • fib :: Int -> Integer
    • fib = (!) (fromListN 200_002 fibonacci)
    • fib = (!!) fibonacci
JohanWiltinkvs.JohanWiltink

Fibonacci with a Skew binary tree cache memoisation .hs

Code
Diff
  • module Example (fib,fibonacci) where

type RAList a = [ ( Int, Tree a ) ]
data Tree a = Empty | Node { here :: a, left, right :: Tree a } deriving ()

nil :: RAList a
nil = []

cons :: a -> RAList a -> RAList a
cons x ( (size0,tree0) : (size1,tree1) : trees ) | size0 == size1 = ( 1 + size0 + size1, Node x tree0 tree1 ) : trees
cons x trees = (1,Node x Empty Empty) : trees

fromListN :: Int -> [a] -> RAList a
fromListN n = foldr cons nil . take n

(!) :: RAList a -> Int -> a
( (size,tree) : trees ) ! n | n < size = index tree size n | otherwise = trees ! (n - size) where
  index tree size n | n == 0     = here tree
                    | n+n < size = index (left  tree) (size `div` 2) (n-1)
                    | otherwise  = index (right tree) (size `div` 2) (n-1 - size `div` 2)  

fibonacci :: [Integer]
fibonacci = 0 : scanl (+) 1 fibonacci

fib :: Int -> Integer
fib = (!) (fromListN 200_002 fibonacci)
    • module Example (fib,fibonacci) where
    • import Data.Bifunctor (bimap)
    • type RAList a = [ ( Int, Tree a ) ]
    • data Tree a = Empty | Node { here :: a, left, right :: Tree a } deriving ()
    • data Tree a = Node { here :: a, left, right :: Tree a } deriving ()
    • nil :: RAList a
    • nil = []
    • fromList :: [a] -> Tree a
    • fromList = head . foldr build undefined . rows 1 where
    • rows l xs = uncurry (:) $ bimap (l,) (rows $ 2*l) $ splitAt l xs
    • build (l,xs) zs = uncurry (zipWith3 Node xs) $ splitAt l zs
    • zipWith3 fn (x:xs) ~(y:ys) ~(z:zs) = fn x y z : zipWith3 fn xs ys zs
    • zipWith3 _ _ _ _ = []
    • (!) :: Tree a -> Int -> a
    • tree ! 0 = here tree
    • tree ! n | odd n = left tree ! (n `div` 2) | otherwise = right tree ! (pred n `div` 2)
    • cons :: a -> RAList a -> RAList a
    • cons x ( (size0,tree0) : (size1,tree1) : trees ) | size0 == size1 = ( 1 + size0 + size1, Node x tree0 tree1 ) : trees
    • cons x trees = (1,Node x Empty Empty) : trees
    • fromListN :: Int -> [a] -> RAList a
    • fromListN n = foldr cons nil . take n
    • (!) :: RAList a -> Int -> a
    • ( (size,tree) : trees ) ! n | n < size = index tree size n | otherwise = trees ! (n - size) where
    • index tree size n | n == 0 = here tree
    • | n+n < size = index (left tree) (size `div` 2) (n-1)
    • | otherwise = index (right tree) (size `div` 2) (n-1 - size `div` 2)
    • fibonacci :: [Integer]
    • fibonacci = 0 : scanl (+) 1 fibonacci
    • fib :: Int -> Integer
    • fib = (!) (fromList fibonacci)
    • fib = (!) (fromListN 200_002 fibonacci)
JohanWiltink

Fibonacci with a Braun tree cache memoisation .hs

module Example (fib,fibonacci) where

import Data.Bifunctor (bimap)

data Tree a = Node { here :: a, left, right :: Tree a } deriving ()

fromList :: [a] -> Tree a
fromList = head . foldr build undefined . rows 1 where
  rows l xs = uncurry (:) $ bimap (l,) (rows $ 2*l) $ splitAt l xs
  build (l,xs) zs = uncurry (zipWith3 Node xs) $ splitAt l zs
  zipWith3 fn (x:xs) ~(y:ys) ~(z:zs) = fn x y z : zipWith3 fn xs ys zs
  zipWith3 _ _ _ _ = []

(!) :: Tree a -> Int -> a
tree ! 0 = here tree
tree ! n | odd n = left tree ! (n `div` 2) | otherwise = right tree ! (pred n `div` 2)

fibonacci :: [Integer]
fibonacci = 0 : scanl (+) 1 fibonacci

fib :: Int -> Integer
fib = (!) (fromList fibonacci)
JohanWiltink

Composite substrings

module CompositeSubstrings (check) where

primes :: (Integral a) => [a]
primes = 2 : ([3..] `minus` composites)

composites :: (Integral a) => [a]
composites = union $ map multiples primes

multiples :: (Integral a) => a -> [a]
multiples n = map (*n) [n..]

minus :: (Integral a) => [a] -> [a] -> [a]
(x:xs) `minus` (y:ys) | x < y  = x : (xs `minus` (y:ys))
                      | x == y = xs `minus` ys
                      | x > y  = (x:xs) `minus` ys

union :: (Integral a) => [[a]] -> [a]
union = foldr merge undefined

merge :: (Integral a) => [a] -> [a] -> [a]
merge (x:xs) ys = x : merge' xs ys

merge' :: (Integral a) => [a] -> [a] -> [a]
merge' (x:xs) (y:ys) | x < y  = x : merge' xs (y:ys)
                     | x == y = x : merge' xs ys
                     | x > y  = y : merge' (x:xs) ys

tails1 :: [a] -> [[a]]
tails1 = takeWhile (not . null) . iterate tail

inits1 :: [a] -> [[a]]
inits1 = foldr ( \ x z -> (x :) <$> [] : z ) []

isComposite n = foldr go undefined composites where
  go composite z | composite > n = False
                 | composite == n = True
                 | otherwise = z

check :: Int -> Bool
check n = not $ any (isComposite . read) $ concatMap tails1 $ inits1 $ show n
JohanWiltink

O(1) snoc?

snoc actually seems to make a faster list than cons

C = \ f x y . f y x
K = \ x _ . x

cons = \ x xs . \ c n . c x (xs c n)
nil = \ _c n . n
snoc = \ xs x . \ c n . xs c (c x n)

succ = \ n . \ s z . s (n s z)

xs = 15 2 (C snoc ()) nil
xs = 15 2 (  cons ()) nil

result = xs (K succ) 0
JohanWiltink

Counting Horses .js

Counting horses without phase alignment

function countHorses(sounds) {
  function* horsify(leg) { for ( let phase=0;; yield [leg+phase,phase++] ); }
  function filter(leg,phase) {
    const sounds_ = Array.from(sounds);
    for ( let i=leg-1-phase; i in sounds; i += leg )
      if ( sounds[i] )
        sounds_[i]--;
      else
        return null;
    return sounds_;
  }
  const leg = 1 + sounds.findIndex(Boolean);
  if ( leg )
    for ( const horse of horsify(leg) ) {
      const r = filter(...horse);
      if ( r )
        return [ horse, ...countHorses(r) ];
    }
  else
    return [];
}
JohanWiltink

Counting Horses .hs

Counting horses without phase alignment

module CountingHorses (countHorses) where

import Data.List (findIndex)
import Data.Foldable (asum)
import Data.Maybe (fromMaybe)

countHorses :: [Int] -> [(Int,Int)]
countHorses sounds = fromMaybe [] $ ( \ leg -> asum $ ( \ horse -> (horse :) . countHorses <$> filter horse ) <$> [ (leg+phase,phase) | phase <- [0..] ] ) =<< succ <$> findIndex (/= 0) sounds where
  filter (leg,phase) | all (>= 0) sounds' = Just sounds' | otherwise = Nothing where
    sounds' = zipWith (-) sounds $ drop phase $ cycle $ replicate (leg-1) 0 ++ [1]
JohanWiltink

Bubble sort .hs

efficient implementation of an inefficient algorithm

module BubbleSort where

bubbleSort :: (Ord a) => [a] -> [a]
bubbleSort xs@(_:_:_) = a : bubbleSort as where
  a:as = foldr bubble [] xs
  bubble x [] = [x]
  bubble x (z:zs) | x <= z    = x : z : zs
                  | otherwise = z : x : zs
bubbleSort xs = xs

bubbleSortBy :: (a -> a -> Ordering) -> [a] -> [a]
bubbleSortBy cmp xs@(_:_:_) = a : bubbleSortBy cmp as where
  a:as = foldr bubble [] xs
  bubble x [] = [x]
  bubble x (z:zs) | cmp x z /= GT = x : z : zs
                  | otherwise     = z : x : zs
bubbleSortBy _ xs = xs
JohanWiltinkvs.hobovsky

TDD Game: sum

Code
Diff
  • module Sum (Sum.sum) where

import Control.Monad.State (State,execState,modify)
import Data.Foldable (for_)

sum :: [Int] -> Int
sum xs = execState (for_ xs add) 0 where
  add :: Int -> State Int ()
  add = modify . (+)
    • module Sum (Sum.sum) where
    • import Control.Monad.State (State,execState,put, get)
    • import Control.Monad.State (State,execState,modify)
    • import Data.Foldable (for_)
    • sum :: [Int] -> Int
    • sum xs = execState (for_ xs add) 0 where
    • add :: Int -> State Int ()
    • add x = do
    • -- modify (+x)
    • y <- get
    • put (y + x)
    • return ()
    • add = modify . (+)
JohanWiltinkvs.hobovskyFailed Tests

TDD Game: sum

for_: "Map each element of a structure to a monadic action, evaluate these actions from left to right, and ignore the results."

Evaluating the actions leads to a state that should hold the final result ( the sum ).

"Ignore the results" means add should always end with return ().

Code
Diff
  • module Sum (Sum.sum) where

import Control.Monad.State (State,execState)
import Data.Foldable (for_)

sum :: [Int] -> Int
sum xs = execState (for_ xs add) 0 where
  add :: Int -> State Int ()
  add x = do
    return ()
    • module Sum (Sum.sum) where
    • import Prelude hiding (sum)
    • import Control.Monad.State (State,execState)
    • import Data.Foldable (for_)
    • sum :: [Word] -> Word
    • sum xs = if xs == [] then 0 else foldr1 (+) xs
    • sum :: [Int] -> Int
    • sum xs = execState (for_ xs add) 0 where
    • add :: Int -> State Int ()
    • add x = do
    • return ()
JohanWiltinkvs.JohanWiltink

TDD Game: sum

sum is again a oneliner, with a correct but flexible signature.

foldr requires t to be Foldable, (+) requires a to be Num, 0 is also Num.

Explain that last test in the comments, or on Discord.

Code
Diff
  • module Sum (Sum.sum) where

import Prelude hiding (sum)

sum :: (Foldable t,Num a) => t a -> a
sum = foldr (+) 0
    • module Sum (Sum.sum) where
    • import Prelude hiding (sum)
    • sum :: (Foldable t) => t Word -> Word
    • sum xs | null xs = 0 | otherwise = foldr1 (+) xs
    • sum :: (Foldable t,Num a) => t a -> a
    • sum = foldr (+) 0
JohanWiltinkvs.NunoOliveira

TDD Game: sum

Get rid of the warnings.

Code
Diff
  • module Sum (Sum.sum) where

import Prelude hiding (sum)

sum :: (Foldable t) => t Word -> Word
sum xs | null xs = 0 | otherwise = foldr1 (+) xs
    • module Sum (Sum.sum) where
    • import Prelude hiding (sum)
    • sum :: Foldable t => t Word -> Word
    • sum :: (Foldable t) => t Word -> Word
    • sum xs | null xs = 0 | otherwise = foldr1 (+) xs
JohanWiltinkvs.hobovskyFailed Tests

TDD Game: sum

Code
Diff
  • module Sum (Sum.sum) where

import Prelude hiding (sum)

sum :: [Word] -> Word
sum xs | null xs = 0 | otherwise = foldr1 (+) xs
    • module Sum (Sum.sum) where
    • import Prelude hiding (sum)
    • sum :: [Word] -> Word
    • sum xs = if xs == [] then 0 else foldr1 (+) xs
    • sum xs | null xs = 0 | otherwise = foldr1 (+) xs
JohanWiltinkvs.hobovsky

TDD Game: sum

Code
Diff
  • module Sum (Sum.sum) where

import Prelude hiding (sum)

sum :: [Word] -> Word
sum xs | null xs = 0 | otherwise = foldr1 (+) xs
    • module Sum (Sum.sum) where
    • import Prelude hiding (sum)
    • sum :: [Word] -> Word
    • sum xs = if xs == [] then 0 else foldr1 (+) xs
    • sum xs | null xs = 0 | otherwise = foldr1 (+) xs
Loading more items...