{-|
Module:    NumberWall
Copyright: (c) Owen Bechtel, 2022
License:   MIT
-}

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
module NumberWall
  ( NumberWall, Col, Row, numberWall, pagoda, rueppel, ternary, saveImage, showSection, printSection
  , module Data.Mod.Word
  ) where

import Prelude hiding (negate, (*), (+), (-), (^), quot)

import Data.Function.Memoize (memoFix2)
import Data.Semiring (Semiring, Ring, zero, one, negate, (*), (+), (-), (^))
import Data.Euclidean (Euclidean, quot)

import Data.Mod.Word
import Codec.Picture (PixelRGB8(..), generateImage, writePng)
import Data.Word (Word8)

{-|
The 'numberWall' function works for any Euclidean domain. (In other words,
there must be some sort of @div@ function, along with addition and multiplication).
Usually, this domain is either 'Integer' or @Mod p@ for some prime number p.
Although 'Int' and @Mod n@ for non-prime n also have 'Euclidean' instances, they
are not actually Euclidean domains, and using 'numberWall' with them often causes
divide-by-zero errors.
-}

type NumberWall a = (Eq a, Ring a, Euclidean a)

type Col = Int
type Row = Int

sign :: Ring a => Int -> a
sign :: forall a. Ring a => Int -> a
sign Int
x = if forall a. Integral a => a -> Bool
even Int
x then forall a. Semiring a => a
one else forall a. Ring a => a -> a
negate forall a. Semiring a => a
one

{-|
Generate the number wall for a sequence.
-}
numberWall :: (NumberWall a, Show a) => (Int -> a) -> Col -> Row -> a
numberWall :: forall a. (NumberWall a, Show a) => (Int -> a) -> Int -> Int -> a
numberWall Int -> a
s = forall a b v.
(Memoizable a, Memoizable b) =>
((a -> b -> v) -> a -> b -> v) -> a -> b -> v
memoFix2 \Int -> Int -> a
recurse Int
col Int
row ->
  let f :: Int -> Int -> a
f Int
a Int
b = Int -> Int -> a
recurse (Int
col forall a. Semiring a => a -> a -> a
+ Int
a) (Int
row forall a. Ring a => a -> a -> a
- Int
b) in
  case Int
row of
    --simple cases
    Int
_ | Int
row forall a. Ord a => a -> a -> Bool
< (-Int
1) -> forall a. Semiring a => a
zero
    -1 -> forall a. Semiring a => a
one
    Int
0 -> Int -> a
s Int
col

    --small cross rule
    Int
_ | Int -> Int -> a
f Int
0 Int
2 forall a. Eq a => a -> a -> Bool
/= forall a. Semiring a => a
zero ->
        (Int -> Int -> a
f Int
0 Int
1 forall a b. (Semiring a, Integral b) => a -> b -> a
^ Integer
2 forall a. Ring a => a -> a -> a
- Int -> Int -> a
f (-Int
1) Int
1 forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f Int
1 Int
1) forall a. Euclidean a => a -> a -> a
`quot` Int -> Int -> a
f Int
0 Int
2

    --large cross rule
      | Int -> Int -> a
f Int
0 Int
3 forall a. Eq a => a -> a -> Bool
/= forall a. Semiring a => a
zero ->
        (Int -> Int -> a
f Int
2 Int
2 forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f (-Int
1) Int
2 forall a b. (Semiring a, Integral b) => a -> b -> a
^ Integer
2 forall a. Semiring a => a -> a -> a
+ Int -> Int -> a
f (-Int
2) Int
2 forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f Int
1 Int
2 forall a b. (Semiring a, Integral b) => a -> b -> a
^ Integer
2 forall a. Ring a => a -> a -> a
- Int -> Int -> a
f Int
0 Int
4 forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f Int
0 Int
1 forall a b. (Semiring a, Integral b) => a -> b -> a
^ Integer
2) forall a. Euclidean a => a -> a -> a
`quot` Int -> Int -> a
f Int
0 Int
3 forall a b. (Semiring a, Integral b) => a -> b -> a
^ Integer
2

    --two rows below window
      | Int -> Int -> a
f Int
0 Int
1 forall a. Eq a => a -> a -> Bool
/= forall a. Semiring a => a
zero ->
        let top :: Int
top = forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findTop Int -> Int -> a
f (Int
0, Int
4)
            size :: Int
size = Int
top forall a. Ring a => a -> a -> a
- Int
2
            right :: Int
right = forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findRight Int -> Int -> a
f (Int
1, Int
top forall a. Ring a => a -> a -> a
- Int
1)
            left :: Int
left = Int
right forall a. Ring a => a -> a -> a
- Int
size forall a. Ring a => a -> a -> a
- Int
1
            k :: Int
k = Int
right

            _A :: a
_A = Int -> Int -> a
f (Int
left forall a. Semiring a => a -> a -> a
+ Int
k) Int
top
            _B :: a
_B = Int -> Int -> a
f Int
left (Int
top forall a. Ring a => a -> a -> a
- Int
k)
            _C :: a
_C = Int -> Int -> a
f Int
right (Int
1 forall a. Semiring a => a -> a -> a
+ Int
k)
            _D :: a
_D = Int -> Int -> a
f Int
0 Int
1

            _E :: a
_E = Int -> Int -> a
f (Int
left forall a. Semiring a => a -> a -> a
+ Int
k) (Int
top forall a. Semiring a => a -> a -> a
+ Int
1)
            _F :: a
_F = Int -> Int -> a
f (Int
left forall a. Ring a => a -> a -> a
- Int
1) (Int
top forall a. Ring a => a -> a -> a
- Int
k)
            _G :: a
_G = Int -> Int -> a
f (Int
right forall a. Semiring a => a -> a -> a
+ Int
1) (Int
1 forall a. Semiring a => a -> a -> a
+ Int
k)

            _P :: a
_P = Int -> Int -> a
f (Int
left forall a. Semiring a => a -> a -> a
+ Int
k forall a. Ring a => a -> a -> a
- Int
1) Int
top
            _Q :: a
_Q = Int -> Int -> a
f Int
left (Int
top forall a. Ring a => a -> a -> a
- Int
k forall a. Semiring a => a -> a -> a
+ Int
1)
            _R :: a
_R = Int -> Int -> a
f Int
right (Int
2 forall a. Semiring a => a -> a -> a
+ Int
k)
            _T :: a
_T = Int -> Int -> a
f (-Int
1) Int
1
        in
        (a
_P forall a. Semiring a => a -> a -> a
* a
_B forall a. Semiring a => a -> a -> a
* a
_B forall a. Semiring a => a -> a -> a
* a
_C forall a. Semiring a => a -> a -> a
* a
_D forall a. Semiring a => a -> a -> a
* a
_E
        forall a. Semiring a => a -> a -> a
+ forall a. Ring a => Int -> a
sign Int
k forall a. Semiring a => a -> a -> a
* a
_Q forall a. Semiring a => a -> a -> a
* a
_A forall a. Semiring a => a -> a -> a
* a
_A forall a. Semiring a => a -> a -> a
* a
_C forall a. Semiring a => a -> a -> a
* a
_D forall a. Semiring a => a -> a -> a
* a
_F
        forall a. Ring a => a -> a -> a
- forall a. Ring a => Int -> a
sign Int
k forall a. Semiring a => a -> a -> a
* a
_T forall a. Semiring a => a -> a -> a
* a
_P forall a. Semiring a => a -> a -> a
* a
_Q forall a. Semiring a => a -> a -> a
* a
_A forall a. Semiring a => a -> a -> a
* a
_B forall a. Semiring a => a -> a -> a
* a
_G)
        forall a. Euclidean a => a -> a -> a
`quot` (a
_R forall a. Semiring a => a -> a -> a
* a
_P forall a. Semiring a => a -> a -> a
* a
_Q forall a. Semiring a => a -> a -> a
* a
_A forall a. Semiring a => a -> a -> a
* a
_B)

      | Bool
otherwise ->
        let top :: Int
top = forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findTop Int -> Int -> a
f (Int
0, Int
4)
            size :: Int
size = Int
top forall a. Ring a => a -> a -> a
- Int
1
        in
        case forall a.
NumberWall a =>
(Int -> Int -> a) -> Int -> (Int, Int) -> Maybe Int
searchRight Int -> Int -> a
f Int
size (Int
1, Int
top forall a. Ring a => a -> a -> a
- Int
1) of
          --inside window
          Maybe Int
Nothing -> forall a. Semiring a => a
zero
          Just Int
right
            | Int -> Int -> a
f (Int
right forall a. Ring a => a -> a -> a
- Int
size forall a. Ring a => a -> a -> a
- Int
1) (Int
top forall a. Ring a => a -> a -> a
- Int
1) forall a. Eq a => a -> a -> Bool
== forall a. Semiring a => a
zero -> forall a. Semiring a => a
zero

          --one row below window
            | Bool
otherwise ->
              let left :: Int
left = Int
right forall a. Ring a => a -> a -> a
- Int
size forall a. Ring a => a -> a -> a
- Int
1
                  k :: Int
k = Int
right
              in
              forall a. Ring a => Int -> a
sign (Int
size forall a. Semiring a => a -> a -> a
* Int
k) forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f Int
left (Int
top forall a. Ring a => a -> a -> a
- Int
k) forall a. Semiring a => a -> a -> a
* Int -> Int -> a
f Int
right Int
k forall a. Euclidean a => a -> a -> a
`quot` Int -> Int -> a
f (Int
left forall a. Semiring a => a -> a -> a
+ Int
k) Int
top

findTop :: NumberWall a => (Col -> Row -> a) -> (Col, Row) -> Row
findTop :: forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findTop Int -> Int -> a
f (Int
col, Int
row)
  | Int -> Int -> a
f Int
col Int
row forall a. Eq a => a -> a -> Bool
== forall a. Semiring a => a
zero = forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findTop Int -> Int -> a
f (Int
col, Int
row forall a. Semiring a => a -> a -> a
+ Int
1)
  | Bool
otherwise = Int
row

findRight :: NumberWall a => (Col -> Row -> a) -> (Col, Row) -> Col
findRight :: forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findRight Int -> Int -> a
f (Int
col, Int
row)
  | Int -> Int -> a
f Int
col Int
row forall a. Eq a => a -> a -> Bool
== forall a. Semiring a => a
zero = forall a. NumberWall a => (Int -> Int -> a) -> (Int, Int) -> Int
findRight Int -> Int -> a
f (Int
col forall a. Semiring a => a -> a -> a
+ Int
1, Int
row)
  | Bool
otherwise = Int
col

searchRight :: NumberWall a => (Col -> Row -> a) -> Int -> (Col, Row) -> Maybe Col
searchRight :: forall a.
NumberWall a =>
(Int -> Int -> a) -> Int -> (Int, Int) -> Maybe Int
searchRight Int -> Int -> a
f Int
limit (Int
col, Int
row)
  | Int
limit forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. Maybe a
Nothing
  | Int -> Int -> a
f Int
col Int
row forall a. Eq a => a -> a -> Bool
== forall a. Semiring a => a
zero = forall a.
NumberWall a =>
(Int -> Int -> a) -> Int -> (Int, Int) -> Maybe Int
searchRight Int -> Int -> a
f (Int
limit forall a. Ring a => a -> a -> a
- Int
1) (Int
col forall a. Semiring a => a -> a -> a
+ Int
1, Int
row)
  | Bool
otherwise = forall a. a -> Maybe a
Just Int
col

{-|
The pagoda sequence ([A301849](https://oeis.org/A301849)).
In mod 2, its number wall is a self-similar fractal.
In mod 3 and mod 7, all zeros in its number wall are isolated.
-}
pagoda :: Ring a => Int -> a
pagoda :: forall a. Ring a => Int -> a
pagoda Int
n = forall {a} {a}. (Semiring a, Integral a) => a -> a
bit (Int
n forall a. Semiring a => a -> a -> a
+ Int
1) forall a. Ring a => a -> a -> a
- forall {a} {a}. (Semiring a, Integral a) => a -> a
bit (Int
n forall a. Ring a => a -> a -> a
- Int
1)
  where
    bit :: a -> a
bit a
k
      | a
k forall a. Eq a => a -> a -> Bool
== a
0 = forall a. Semiring a => a
zero
      | forall a. Integral a => a -> Bool
even a
k = a -> a
bit (a
k forall a. Integral a => a -> a -> a
`div` a
2)
      | a
k forall a. Integral a => a -> a -> a
`mod` a
4 forall a. Eq a => a -> a -> Bool
== a
1 = forall a. Semiring a => a
zero
      | Bool
otherwise = forall a. Semiring a => a
one

{-|
The Fredholm-Rueppel sequence ([A036987](https://oeis.org/A036987)).
@rueppel n@ evaluates to 1 if n + 1 is a power of 2, and 0 otherwise.
Its number wall contains zero-windows of exponentially increasing size, and
an infinite diagonal line of ones.
-}
rueppel :: Semiring a => Int -> a
rueppel :: forall a. Semiring a => Int -> a
rueppel Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Semiring a => a
zero
  | Bool
otherwise =
    let pow :: Double
pow = forall a. Floating a => a -> a -> a
logBase Double
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n forall a. Semiring a => a -> a -> a
+ Int
1))
    in if forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
pow forall a. Eq a => a -> a -> Bool
== forall a b. (RealFrac a, Integral b) => a -> b
floor Double
pow then forall a. Semiring a => a
one else forall a. Semiring a => a
zero

data Alpha = A | B | C | D | E | F

{-|
([A039974](https://oeis.org/A039974)). The mod-3 number wall of this sequence
has an infinite central region with no zeros.
-}
ternary :: Ring a => Int -> a
ternary :: forall a. Ring a => Int -> a
ternary Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Ring a => a -> a
negate (forall a. Ring a => Int -> a
ternary (-Int
n forall a. Ring a => a -> a -> a
- Int
1))
  | Bool
otherwise =
    case forall {t}. Integral t => t -> Alpha
ternary' Int
n of
      Alpha
A -> forall a. Semiring a => a
one
      Alpha
B -> forall a. Semiring a => a
zero
      Alpha
C -> forall a. Semiring a => a
one
      Alpha
D -> forall a. Semiring a => a
zero
      Alpha
E -> forall a. Ring a => a -> a
negate forall a. Semiring a => a
one
      Alpha
F -> forall a. Ring a => a -> a
negate forall a. Semiring a => a
one
    where
      ternary' :: t -> Alpha
ternary' t
0 = Alpha
A
      ternary' t
x =
        let (t
q, t
m) = t
x forall a. Integral a => a -> a -> (a, a)
`divMod` t
3
            match3 :: p -> p -> p -> p
match3 p
a p
b p
c =
              case t
m of
                t
0 -> p
a
                t
1 -> p
b
                t
_ -> p
c
        in case t -> Alpha
ternary' t
q of
          Alpha
A -> forall {p}. p -> p -> p -> p
match3 Alpha
A Alpha
C Alpha
B
          Alpha
B -> forall {p}. p -> p -> p -> p
match3 Alpha
B Alpha
C Alpha
B
          Alpha
C -> forall {p}. p -> p -> p -> p
match3 Alpha
E Alpha
D Alpha
F
          Alpha
D -> forall {p}. p -> p -> p -> p
match3 Alpha
D Alpha
D Alpha
D
          Alpha
E -> forall {p}. p -> p -> p -> p
match3 Alpha
E Alpha
D Alpha
D
          Alpha
F -> forall {p}. p -> p -> p -> p
match3 Alpha
D Alpha
D Alpha
F

{-|
RGB colors.
-}
type Color = (Word8, Word8, Word8)

{-|
Save a number wall as a PNG file.
-}
saveImage
  :: FilePath          -- ^ File name
  -> (a -> Color)      -- ^ Function assigning each number a color
  -> (Col, Col)        -- ^ Column range
  -> (Row, Row)        -- ^ Row range
  -> (Col -> Row -> a) -- ^ Number wall
  -> IO ()
saveImage :: forall a.
FilePath
-> (a -> Color)
-> (Int, Int)
-> (Int, Int)
-> (Int -> Int -> a)
-> IO ()
saveImage FilePath
path a -> Color
toColor (Int
minC, Int
maxC) (Int
minR, Int
maxR) Int -> Int -> a
wall =
  let convert :: Color -> PixelRGB8
convert (Pixel8
r, Pixel8
g, Pixel8
b) = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b
      image :: Image PixelRGB8
image = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage
        (\Int
a Int
b -> Color -> PixelRGB8
convert forall a b. (a -> b) -> a -> b
$ a -> Color
toColor forall a b. (a -> b) -> a -> b
$ Int -> Int -> a
wall (Int
minC forall a. Semiring a => a -> a -> a
+ Int
a) (Int
minR forall a. Semiring a => a -> a -> a
+ Int
b))
        (Int
maxC forall a. Ring a => a -> a -> a
- Int
minC) (Int
maxR forall a. Ring a => a -> a -> a
- Int
minR)
  in forall pixel. PngSavable pixel => FilePath -> Image pixel -> IO ()
writePng FilePath
path Image PixelRGB8
image

loop :: [a] -> (a -> b) -> [b]
loop = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map

maxOf :: (a -> b) -> t a -> b
maxOf a -> b
measure = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Ord a => a -> a -> a
max forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
measure) forall a. Bounded a => a
minBound

{-|
Convert a section of a number wall into a string.
-}
showSection :: (a -> String) -> (Col, Col) -> (Row, Row) -> (Col -> Row -> a) -> String
showSection :: forall a.
(a -> FilePath)
-> (Int, Int) -> (Int, Int) -> (Int -> Int -> a) -> FilePath
showSection a -> FilePath
toString (Int
minC, Int
maxC) (Int
minR, Int
maxR) Int -> Int -> a
wall =
  let chunks :: [[FilePath]]
chunks = forall {a} {b}. [a] -> (a -> b) -> [b]
loop [Int
minR..Int
maxRforall a. Ring a => a -> a -> a
-Int
1] \Int
r -> forall {a} {b}. [a] -> (a -> b) -> [b]
loop [Int
minC..Int
maxCforall a. Ring a => a -> a -> a
-Int
1] \Int
c -> a -> FilePath
toString (Int -> Int -> a
wall Int
c Int
r)
      len :: Int
len = forall {t :: * -> *} {b} {a}.
(Foldable t, Ord b, Bounded b) =>
(a -> b) -> t a -> b
maxOf (forall {t :: * -> *} {b} {a}.
(Foldable t, Ord b, Bounded b) =>
(a -> b) -> t a -> b
maxOf forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[FilePath]]
chunks
      pad :: FilePath -> FilePath
pad FilePath
s = forall a. Int -> a -> [a]
replicate (Int
len forall a. Ring a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s) Char
' ' forall a. [a] -> [a] -> [a]
++ FilePath
s forall a. [a] -> [a] -> [a]
++ FilePath
" "
  in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[FilePath]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> FilePath
pad [FilePath]
xs forall a. [a] -> [a] -> [a]
++ FilePath
"\n") [[FilePath]]
chunks

{-|
Print a section of a number wall.
-}
printSection :: (a -> String) -> (Col, Col) -> (Row, Row) -> (Col -> Row -> a) -> IO ()
printSection :: forall a.
(a -> FilePath)
-> (Int, Int) -> (Int, Int) -> (Int -> Int -> a) -> IO ()
printSection a -> FilePath
toString (Int, Int)
cols (Int, Int)
rows Int -> Int -> a
wall = FilePath -> IO ()
putStr (forall a.
(a -> FilePath)
-> (Int, Int) -> (Int, Int) -> (Int -> Int -> a) -> FilePath
showSection a -> FilePath
toString (Int, Int)
cols (Int, Int)
rows Int -> Int -> a
wall)