Stroke-counting function for Sino-Japanese numbers

Strokes.hs

-- Stroke-counting function for Sino-Japanese numbers

module Strokes where

import Data.Ord (comparing)
import Data.List (elemIndex, maximumBy)

ichi = "一"
ni = "二"
san = "三"
yon = "四"
go = "五"
roku = "六"
nana = "七"
hachi = "八"
kyuu = "九"
juu = "十"
hyaku = "百" -- hundred
sen = "千" -- thousand
-- note: the following must always be preceeded by a number, unlike earlier ones
man = "万" -- ten thousand
oku = "億" -- hundred million
tchou = "兆" -- trillion

ichiman, ichioku, itchou, limit :: Integral a => a
ichiman = 10000
ichioku = ichiman * ichiman
itchou = ichiman * ichioku
limit = ichiman * itchou

strokes :: String -> Int
strokes "" = 0
strokes ('一':xs) = 1 + strokes xs
strokes ('二':xs) = 2 + strokes xs
strokes ('三':xs) = 3 + strokes xs
strokes ('四':xs) = 5 + strokes xs
strokes ('五':xs) = 4 + strokes xs
strokes ('六':xs) = 4 + strokes xs
strokes ('七':xs) = 2 + strokes xs
strokes ('八':xs) = 2 + strokes xs
strokes ('九':xs) = 2 + strokes xs
strokes ('十':xs) = 2 + strokes xs
strokes ('百':xs) = 6 + strokes xs
strokes ('千':xs) = 3 + strokes xs
strokes ('万':xs) = 3 + strokes xs
strokes ('億':xs) = 15 + strokes xs
strokes ('兆':xs) = 6 + strokes xs
strokes (x:_) = error $ "Unknown character: " ++ (x:"")

spell :: Integral a => a -> String
spell 1 = ichi
spell 2 = ni
spell 3 = san
spell 4 = yon
spell 5 = go
spell 6 = roku
spell 7 = nana
spell 8 = hachi
spell 9 = kyuu
spell 10 = juu
spell 100 = hyaku
spell 1000 = sen
spell x
  | x < 1 = error "Only positive integers"
  | x < 100 = spell1 (x `div` 10) ++ juu ++ spell0 (x `mod` 10)
  | x < 1000 = spell1 (x `div` 100) ++ hyaku ++ spell0 (x `mod` 100)
  | x < ichiman = spell1 (x `div` 1000) ++ sen ++ spell0 (x `mod` 1000)
  | x < ichioku = spell (x `div` 10000) ++ man ++ spell0 (x `mod` 10000)
  | x < itchou = spell (x `div` ichioku) ++ oku ++ spell0 (x `mod` ichioku)
  | x < limit = spell (x `div` itchou) ++ tchou ++ spell0 (x `mod` itchou)
  | otherwise = error "I don't know how to count that high"
  where spell1 x = if x == 1 then "" else spell x
        spell0 x = if x == 0 then "" else spell x

value :: String -> Integer
value "" = 0
value x
  | x == ichi = 1
  | x == ni = 2
  | x == san = 3
  | x == yon = 4
  | x == go = 5
  | x == roku = 6
  | x == nana = 7
  | x == hachi = 8
  | x == kyuu = 9
  | has tchou = split tchou itchou
  | has oku = split oku ichioku
  | has man = split man ichiman
  | has sen = split sen 1000
  | has hyaku = split hyaku 100
  | has juu = split juu 10
  where has = (`elem` x) . head
        split char val = let Just i = elemIndex (head char) x
                         in val * front i + back i
        front i = max 1 $ value $ take i x
        back i = value $ drop (i + 1) x

fix :: Eq a => (a -> a) -> a -> [a]
fix f x = fix' [x]
  where fix' xs | head xs `elem` tail xs = reverse xs
                | otherwise = fix' $ f (head xs) : xs

findLongest :: Int -> [Int]
findLongest n = maximumBy (comparing length) $ map (fix $ strokes . spell) [1..n]

printTable :: Int -> IO ()
printTable n = mapM_ (print . fix (strokes . spell)) [1..n]

-- Upshot:
-- Fixed points at 1, 2, 3, cycle at (4, 5)
-- Most single-digit numbers end up at 2.
-- First occurence of given length:
--   1 => 1
--   2 => 4
--   3 => 6
--   4 => 15
--   5 => 124
--   6 => 14444444444444 (??)