Joseph-Bake

Joseph-Bake

入力
3

出力
(><)/ wahoo!
(><)/ wahoo!!
(><)/ wahoo!!!
good bye

Joseph-Bake

import Graphics.Gloss

main :: IO()
main =
  animate
    (InWindow "合宿問題" (xsize,ysize) (200,200))
    white
    drawFunc

drawFunc t = pictures [funcs n t | n <- [1..5]]

Joseph-Bake

-- Takeuchi Function

import Graphics.Gloss

type Tarai = (Int,Int,Int)

main :: IO()
main =
  animate
    (InWindow "竹内関数可視化" (600,400) (200,200))

Joseph-Bake

-- n次元 Takeuchi Function
type Tarai = [Int]

main :: IO()
main = print $ length $ ntaraiList initarai

ntarai :: Tarai -> Int
ntarai (a:b:xs)
  | a <= b   = b
  | a >  b   = ntarai (map ntarai (minus1 (krkr (a:b:xs))))

Joseph-Bake

-- Beklemishev's worms

worm :: Integer -> [Integer] -> Integer
worm step [] = step
worm step x = worm (step+1) (next step x)

next :: Integer -> [Integer] -> [Integer]
next _ [] = []
next step x
  | last x == 0      = init x

Joseph-Bake

-- Beklemishev's worms

worm :: Integer -> [Integer] -> Integer
worm step [] = step
worm step x
  | x == [1]    = 2*step + 3
  | length x >= 2 && drop (length x - 2) x == [0,1]  = worm (from01 step) (init (init x))
  | length x >= 3 && drop (length x - 3) x == [0,1,1]    = worm (from011 (step+2)) (init$init$init x)
  | otherwise   = worm (step+1) (next step x)

Joseph-Bake

type NF = (Integer,Integer -> Integer)
type NFM = (Integer,Integer -> Integer,NF -> NF)

--S変換
s :: NF -> NF
s (m,f)  =  (g m,g)
  where
    g :: Integer -> Integer
    g n = b n n
    b :: Integer -> Integer -> Integer

Joseph-Bake

type NF = (Integer,Integer -> Integer)
type NFM = (Integer,Integer -> Integer,NF -> NF)

s :: NF -> NF
s (m,f)  =  (g m,g)
  where
    g :: Integer -> Integer
    g n = b n n
    b :: Integer -> Integer -> Integer
    b 0 l = f l

Joseph-Bake

-- multivariable Ackermann function

nAck :: [Integer] -> Integer
nAck [] = 0
nAck x
  | length x == 1                      = head x + 1
  | head x == 0                        = nAck (tail x)
  | last x == 0 && last (init x) >= 1  = nAck (init (init x) ++ [last (init x)-1,1])
  | last x >= 1 && last (init x) >= 1  = nAck (init (init x) ++ [last (init x)-1] ++ [nAck (init x ++ [last x-1])])
  | last x >= 0 && snd (y x) >= 1 && last (fst (y x)) >= 1