prime factorization

Main.purs

module Main where

import Prelude

import Concur.Core (Widget)
import Concur.Core.FRP (debounce, display, dyn)
import Concur.React (HTML)
import Concur.React.DOM  as D
import Concur.React.Props  as P
import Concur.React.Run (runWidgetInDom)
import Concur.React.SVG as S
import Data.Array as Array
import Data.Int (fromString)
import Data.List.Lazy (List, nil, iterate, filter,  (:), concat, foldl)
import Data.List.Lazy (head, tail, toUnfoldable) as Lazy
import Data.Maybe (fromMaybe, maybe)
import Data.String (length)
import Data.Tuple (fst, snd)
import Data.Tuple.Nested ((/\), type (/\))
import Effect (Effect)
import Effect.Exception (throw)
import Web.DOM.Element (setId)
import Web.HTML (window)
import Web.HTML.HTMLDocument as HTMLDocument
import Web.HTML.HTMLElement as HTMLElement
import Web.HTML.Window (document)

widget :: String -> Widget HTML Unit
widget str = dyn $ do
  display $ D.text "Décomposition en produit de facteurs premiers de "
  inp <- debounce 50.0 str $ \s -> 
    D.input [ P.value s
            , P.unsafeTargetValue <$> P.onChange
            , P.size 8
            ] 
  display $  D.div'
    [
     S.svg 
        [ P.width "600"
        , P.height "500"
        , P.viewBox "200 100 800 500"  
        ] $ pretty $ factor (
          let n = fromMaybe 1 $ fromString inp
              in if n < 1 || n > 2147483646
                then 1
                else n)
    ]

divides :: Int -> Int -> Boolean
divides a b = b `mod` a  == 0

intsFrom :: Int -> List Int
intsFrom  i = iterate (_ + 1) i

primes :: List Int
primes = 
   let isPrime n = 
         let isPrimeWith i = 
               if (i*i) > n 
                   then true 
                   else (not $ divides i n) && (isPrimeWith $ i+1) 
          in isPrimeWith 2
    in filter isPrime (intsFrom 2)

head :: List Int -> Int
head xs = fromMaybe (-1) (Lazy.head xs) 

tail :: forall a. List a -> List a
tail xs = fromMaybe nil (Lazy.tail xs) 

prime :: Int -> Boolean /\ Int
prime n = 
   let ldpf ps = 
        let p = head ps 
         in if divides p n
            then p/\p
            else if n<(p*p) 
                    then n/\n
                    else ldpf (tail ps)
    in if n==1 then false/\1
               else let ldpn = ldpf primes 
                    in ((fst ldpn)==n)/\(snd ldpn)

factor :: Int -> List (Int /\ Int)
factor m = 
    let factorImpl acc n current cpt =
         if n==1 
          then acc
          else 
            let bool = prime n
                nogarbage = 
                  if current == 0 
                    then acc 
                    else (current/\cpt):acc
                m' = snd bool
              in if fst bool 
                  then
                    if m' == current
                      then (m' /\ (cpt+1)):acc
                      else (m' /\ 1):nogarbage 
                  else 
                    if m' == current
                      then factorImpl acc (n/m') current (cpt+1)
                      else factorImpl nogarbage (n/m') m'  1
         in factorImpl nil m 0 0

text :: forall a. Int -> Int -> Int -> String -> Widget HTML a
text x y size str = 
  S.text [ P.unsafeMkProp "x" $ x 
            , P.unsafeMkProp "y" y
            , P.unsafeMkProp "fontSize" size
            , P.fill "#000000"
    ] [D.text str]

stdSize = 40 :: Int
stdWidth = 25 :: Int
exponentSize = 25 :: Int
exponentWidth = 14 :: Int
yStd = 100 :: Int
yExponent = 70 :: Int

pretty :: forall a. List (Int /\ Int) -> Array (Widget HTML a)
pretty xs =
  let ys = Lazy.toUnfoldable $ tail $ concat $ (\x -> (0/\0):x:nil) <$> xs
      toText (n/\p) =
        case p of
          0 -> [ { x: 2, y: yStd, size: stdSize, str: "✕", width: stdWidth} ]
          1 -> [ { x: length (show n), y: yStd, size: stdSize, str: show n, width: stdWidth } ]
          _ -> [ { x: length (show p), y: yExponent, size: exponentSize, str: show p, width: exponentWidth }
               , { x: length (show n), y: yStd, size: stdSize, str: show n, width: stdWidth }
               ]
  in fst $ foldl (\ (acc/\off){x,y,size,str,width}  ->
    (text (off-x*width) y size str Array.: acc)/\(off-x*width)
  ) ([]/\800) $ (Array.concat $ toText <$> ys)

main :: Effect Unit 
main = do
  doc <- document =<< window
  body <- maybe (throw "body not found") pure =<< HTMLDocument.body doc
  setId "main" $ HTMLElement.toElement body
  runWidgetInDom "main" $ widget ""