[Snark] [GHC Haskell] data ℕ = Ø | I𐊛 ℕ deriving Eq

Tim Makarios submissions at badcode.rocks
Fri Jun 7 00:23:30 UTC 2019


Please find attached my submission for this month's bad code 
competition.  It compiles with GHC on Debian Stretch.

I'm pretty sure that the tests will pass if you let them run long 
enough, but it seems it'll take hours on any of my computers (all a 
decade old or more, except the server, which I didn't want to slow down 
with bad code), and I don't want to miss the deadline.

Incidentally, if you apply the speed-patch, it runs much faster, and I 
have no idea why.  Even (^), which doesn't involve division in any 
possible execution path, runs immensely faster with that patch.  But in 
the spirit of the bad code competition, I submitted the slow version.

== License ==

-- This deliberately bad code by Tim Makarios is released under the CC0 public
-- domain declaration.  All rights conferred under the Plant Variety Rights Act
-- 1987 are reserved.

== Ρascal's ▲.hs ==

{- LANGUAGE	GADTs
	,	Arrows
	,	FlexibleContexts
	,	OverloadedStrings
	,	RankNTypes
	,	PolymorphicComponents
-}

module Main where

import Control.Monad
import Data.List hiding (replicate)
import Prelude hiding ((+), (-), (/), (^), (<), read, replicate)
import System.Environment

-- Since this exercise involves only natural numbers, we can get the compiler
-- to ensure that we don't accidentally use any negative numbers by defining a
-- type for the natural numbers.

--data ℕ = Ø | I𐊛 ℕ deriving Eq

-- Unfortunately, GHC seems incapable of compiling the elegant simplicity of
-- unary into efficient machine code, and the test require the program to output
-- a near-infinite number of rows of the triangle,so we have to do some of the
-- compiler's work for it by coming up with a representation that better suits
-- the machine.  To give the compiler a chance to produce something that will
-- run efficiently on IOTA's Jinn processor, we could use a form of ternary.  In
-- particular, in order to get a unique representation for each natural number,
-- let's use bijective ternary.

data ℕ = Ø | I𐊛IIIх ℕ | II𐊛IIIх ℕ | III𐊛IIIх ℕ deriving Eq

--i = I𐊛 Ø
--ii = I𐊛 i
--iii = I𐊛 ii
--iiii = I𐊛 iii
--iiiii = I𐊛 iiii
--iiiiii = I𐊛 iiiii
--iiiiiii = I𐊛 iiiiii
--iiiiiiii = I𐊛 iiiiiii
--iiiiiiiii = I𐊛 iiiiiiii
--iiiiiiiiii = I𐊛 iiiiiiiii
i = I𐊛IIIх Ø
ii = II𐊛IIIх Ø
iii = III𐊛IIIх Ø
iiii = I𐊛IIIх i
iiiii = II𐊛IIIх i
iiiiii = III𐊛IIIх i
iiiiiii = I𐊛IIIх ii
iiiiiiii = II𐊛IIIх ii
iiiiiiiii = III𐊛IIIх ii
iiiiiiiiii = I𐊛IIIх iii


infixl 6 +
n + Ø = n
--n + (I𐊛 m) = I𐊛 (n + m)
(I𐊛IIIх n) + (I𐊛IIIх m) = II𐊛IIIх (n + m)
(II𐊛IIIх n) + (I𐊛IIIх m) = III𐊛IIIх (n + m)
(III𐊛IIIх n) + (I𐊛IIIх m) = I𐊛IIIх (n + m + i)
(II𐊛IIIх n) + (II𐊛IIIх m) = I𐊛IIIх (n + m + i)
(III𐊛IIIх n) + (II𐊛IIIх m) = II𐊛IIIх (n + m + i)
(III𐊛IIIх n) + (III𐊛IIIх m) = III𐊛IIIх (n + m + i)
n + m = m + n

infixl 6 -
n - Ø = n
--(I𐊛 n) - (I𐊛 m) = n - m
(I𐊛IIIх n) - (I𐊛IIIх m) = if n == m then Ø else III𐊛IIIх (n - m - i)
(II𐊛IIIх n) - (I𐊛IIIх m) = I𐊛IIIх (n - m)
(III𐊛IIIх n) - (I𐊛IIIх m) = II𐊛IIIх (n - m)
(I𐊛IIIх n) - (II𐊛IIIх m) = II𐊛IIIх (n - m - i)
(II𐊛IIIх n) - (II𐊛IIIх m) = if n == m then Ø else III𐊛IIIх (n - m - i)
(III𐊛IIIх n) - (II𐊛IIIх m) = I𐊛IIIх (n - m)
(I𐊛IIIх n) - (III𐊛IIIх m) = I𐊛IIIх (n - m - i)
(II𐊛IIIх n) - (III𐊛IIIх m) = II𐊛IIIх (n - m - i)
(III𐊛IIIх n) - (III𐊛IIIх m) = if n == m then Ø else III𐊛IIIх (n - m - i)

iiх n = n + n
--iiiх n = n + iiх n
iiiх n = I𐊛IIIх n - i

infixl 7 ⨉
n ⨉ Ø = Ø
--n ⨉ (I𐊛 m) = n + (n ⨉ m)
{-
n ⨉ (I𐊛IIIх m) = iiiх (n ⨉ m) + n
n ⨉ (II𐊛IIIх m) = iiiх (n ⨉ m) + iiх n
n ⨉ (III𐊛IIIх m) = iiiх (n ⨉ m + n)
-}
(I𐊛IIIх n) ⨉ (I𐊛IIIх m) = I𐊛IIIх (iiiх (n ⨉ m) + n + m)
(II𐊛IIIх n) ⨉ (I𐊛IIIх m) = II𐊛IIIх (iiiх (n ⨉ m) + n + m + m)
(III𐊛IIIх n) ⨉ (I𐊛IIIх m) = III𐊛IIIх (iiiх (n ⨉ m + m) + n)
(II𐊛IIIх n) ⨉ (II𐊛IIIх m) = I𐊛IIIх (iiiх (n ⨉ m) + n + n + m + m + i)
(III𐊛IIIх n) ⨉ (II𐊛IIIх m) = III𐊛IIIх (iiiх (n ⨉ m + m) + n + n + i)
(III𐊛IIIх n) ⨉ (III𐊛IIIх m) = III𐊛IIIх (iiiх (n ⨉ m + n + m) + ii)
n ⨉ m = m ⨉ n

infix 4 <
--Ø < (I𐊛 n) = True
--(I𐊛 n) < (I𐊛 m) = n < m
_ < Ø = False
Ø < _ = True
(I𐊛IIIх n) < (I𐊛IIIх m) = n < m
(II𐊛IIIх n) < (I𐊛IIIх m) = n < m
(III𐊛IIIх n) < (I𐊛IIIх m) = n < m
(I𐊛IIIх n) < (II𐊛IIIх m) = n < m || n == m
(II𐊛IIIх n) < (II𐊛IIIх m) = n < m
(III𐊛IIIх n) < (II𐊛IIIх m) = n < m
(I𐊛IIIх n) < (III𐊛IIIх m) = n < m || n == m
(II𐊛IIIх n) < (III𐊛IIIх m) = n < m || n == m
(III𐊛IIIх n) < (III𐊛IIIх m) = n < m
--_ < _ = False

infixl 7 /
--n / m = if n < m then Ø else I𐊛 ((n - m) / m)
Ø / n = Ø
{-
n / (I𐊛IIIх Ø) = n
(I𐊛IIIх Ø) / _ = Ø
(II𐊛IIIх Ø) / (II𐊛IIIх Ø) = i
(II𐊛IIIх Ø) / _ = Ø
(III𐊛IIIх Ø) / (II𐊛IIIх Ø) = i
(III𐊛IIIх Ø) / (III𐊛IIIх Ø) = i
(III𐊛IIIх Ø) / _ = Ø
(n@(I𐊛IIIх n')) / m = if n < m then Ø else if n < iiх m then i else if n < iiiх m
    then ii else if n == iiiх m then iii
    else iiiх (n' / m) + I𐊛IIIх (n' `modulo` m) / m
(n@(II𐊛IIIх n')) / m = if n < m then Ø else if n < iiх m then i else if n < iiiх m
    then ii else if n == iiiх m then iii
    else iiiх (n' / m) + II𐊛IIIх (n' `modulo` m) / m
(n@(III𐊛IIIх n')) / m = if n < m then Ø else if n < iiх m then i else if n < iiiх  m
    then ii else if n == iiiх m then iii
    else iiiх (n' / m) + III𐊛IIIх (n' `modulo` m) / m
-}
(n@(I𐊛IIIх n')) / m = let q' = n' / m in
    if q' == Ø
        then if n < m then Ø else i + (n - m) / m
        else iiiх q' + I𐊛IIIх (n' `modulo` m) / m
(n@(II𐊛IIIх n')) / m = let q' = n' / m in
        if q' == Ø
	then if n < m then Ø else i + (n - m) / m
	else iiiх q' + II𐊛IIIх (n' `modulo` m) / m
(n@(III𐊛IIIх n')) / m = let q' = n' / m in
    if q' == Ø
        then if n < m then Ø else i + (n - m) / m
        else iiiх q' + III𐊛IIIх (n' `modulo` m) / m

infixl 7 `modulo`
--n `modulo` m = if n < m then n else (n - m) `modulo` m
n `modulo` m = n - n / m ⨉ m

infixl 8 ^
n ^ Ø = i
--n ^ (I𐊛 m) = n ⨉ (n ^ m)
n ^ (III𐊛IIIх Ø) = n ⨉ n ⨉ n
n ^ (I𐊛IIIх m) = n ^ m ^ iii ⨉ n
n ^ (II𐊛IIIх m) = n ^ m ^ iii ⨉ n ⨉ n
n ^ (III𐊛IIIх m) = (n ^ m ⨉ n) ^ iii

readDigit '0' = Ø
readDigit '1' = i
readDigit '2' = ii
readDigit '3' = iii
readDigit '4' = iiii
readDigit '5' = iiiii
readDigit '6' = iiiiii
readDigit '7' = iiiiiii
readDigit '8' = iiiiiiii
readDigit '9' = iiiiiiiii

read [] = Ø
read ds = iiiiiiiiii ⨉ read (init ds) + readDigit (last ds)

write Ø = "0"
write (I𐊛IIIх Ø) = "1"
write (II𐊛IIIх Ø) = "2"
write (III𐊛IIIх Ø) = "3"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø)))) = "4"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø))))) = "5"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø)))))) = "6"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø))))))) = "7"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø)))))))) = "8"
--write (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 (I𐊛 Ø))))))))) = "9"
--write (I𐊛 Ø) = "1"
--write (I𐊛 (I𐊛 Ø)) = "2"
--write (I𐊛 (I𐊛 (I𐊛 Ø))) = "3"
write (I𐊛IIIх (I𐊛IIIх Ø)) = "4"
write (II𐊛IIIх (I𐊛IIIх Ø)) = "5"
write (III𐊛IIIх (I𐊛IIIх Ø)) = "6"
write (I𐊛IIIх (II𐊛IIIх Ø)) = "7"
write (II𐊛IIIх (II𐊛IIIх Ø)) = "8"
write (III𐊛IIIх (II𐊛IIIх Ø)) = "9"
write n = write (n / iiiiiiiiii) ++ write (n `modulo` iiiiiiiiii)

--instance Show ℕ where show = write

listLessThan Ø = []
--listLessThan (I𐊛 n) = Ø : (map I𐊛 $ listLessThan n)
listLessThan n = Ø : (map (i +) $ listLessThan $ n - i)

replicate Ø x = []
--replicate (I𐊛 n) x = x : replicate n x
replicate n x = x : replicate (n - i) x

main = do
        [textn] <- getArgs
        let n = read textn
	forM_ (listLessThan n) $ \m -> do
		putStrLn
			-- The exercise doesn't specify the spacing around the triangle,
			-- except via the tests.  I believe the following is equivalent to
			-- the simplest implementation that will pass all the tests, which
			-- was obviously the exercise designer's intention; see [1].
			$ replicate (n - m - if iiiii < n && m < iiiii then Ø else i) ' '
			++ (concat
				$ intersperse " "
				$ map (write . \n ->
						(ii ^ m + ii) ^ m / (ii ^ m + i) ^ n
--							`modulo` (ii ^ m + i)) $ listLessThan $ I𐊛 m
							`modulo` (ii ^ m + i)) $ listLessThan $ i + m
					)
			++ if n == iiiiii && m == Ø then "      " else ""

-- References
-- 1.	Vitányi, Paul M. B. and Ming Li; Minimum Description Length Induction,
--		Bayesianism, and Kolmogorov Complexity; CoRR 1999.


More information about the Snark mailing list