Data commit

Task/Humble-numbers/Elm/humble-numbers.elm

@@ -0,0 +1,183 @@
+module Main exposing (main)
+
+import Browser
+import Html exposing (div, pre, text, br)
+import Task exposing (Task, succeed, andThen, perform)
+import BigInt
+import Bitwise exposing (shiftRightBy, and)
+import Time exposing (now, posixToMillis)
+
+-- an infinite non-empty non-memoizing Co-Inductive Stream (CIS)...
+type CIS a = CIS a (() -> CIS a)
+
+takeCIS2String : Int -> (a -> String) -> CIS a -> String
+takeCIS2String n cvtf cis =
+  let loop i (CIS hd tl) lst =
+        if i < 1 then List.reverse lst |> String.join ", "
+        else loop (i - 1) (tl()) (cvtf hd :: lst)
+  in loop n cis []
+
+-- a Min Heap binary heap Priority Queue...
+type PriorityQ comparable v =
+  Mt
+  | Br comparable v (PriorityQ comparable v)
+                    (PriorityQ comparable v)
+
+emptyPQ : PriorityQ comparable v
+emptyPQ = Mt
+
+peekMinPQ : PriorityQ comparable v -> Maybe (comparable, v)
+peekMinPQ  pq = case pq of
+                  (Br k v _ _) -> Just (k, v)
+                  Mt -> Nothing
+
+pushPQ : comparable -> v -> PriorityQ comparable v
+           -> PriorityQ comparable v
+pushPQ wk wv pq =
+  case pq of
+    Mt -> Br wk wv Mt Mt
+    (Br vk vv pl pr) ->
+      if wk <= vk then Br wk wv (pushPQ vk vv pr) pl
+      else Br vk vv (pushPQ wk wv pr) pl
+
+siftdown : comparable -> v -> PriorityQ comparable v
+             -> PriorityQ comparable v -> PriorityQ comparable v
+siftdown wk wv pql pqr =
+  case pql of
+    Mt -> Br wk wv Mt Mt
+    (Br vkl vvl pll prl) ->
+      case pqr of
+        Mt -> if wk <= vkl then Br wk wv pql Mt
+              else Br vkl vvl (Br wk wv Mt Mt) Mt
+        (Br vkr vvr plr prr) ->
+          if wk <= vkl && wk <= vkr then Br wk wv pql pqr
+          else if vkl <= vkr then Br vkl vvl (siftdown wk wv pll prl) pqr
+               else Br vkr vvr pql (siftdown wk wv plr prr)
+
+replaceMinPQ : comparable -> v -> PriorityQ comparable v
+                 -> PriorityQ comparable v
+replaceMinPQ wk wv pq = case pq of
+                          Mt -> Mt
+                          (Br _ _ pl pr) -> siftdown wk wv pl pr
+
+-- actual humble function implementation...
+type alias Mults = { x2 : Int, x3 : Int, x5 : Int, x7 : Int }
+type alias LogRep = { lg : Float, mlts : Mults }
+oneLogRep : LogRep
+oneLogRep = LogRep 0.0 <| Mults 0 0 0 0
+lg10 : Float
+lg10 = 1.0
+lg7 : Float
+lg7 = logBase 10 7
+lg5 : Float
+lg5 = logBase 10.0 5.0
+lg3 : Float
+lg3 = logBase 10.0 3.0
+lg2 : Float
+lg2 = lg10 - lg5
+multLR2 : LogRep -> LogRep
+multLR2 ({ lg, mlts } as lr) =
+  { lr | lg = lg + lg2, mlts = { mlts | x2 = mlts.x2 + 1 } }
+multLR3 : LogRep -> LogRep
+multLR3 ({ lg, mlts } as lr) =
+  { lr | lg = lg + lg3, mlts = { mlts | x3 = mlts.x3 + 1 } }
+multLR5 : LogRep -> LogRep
+multLR5 ({ lg, mlts } as lr) =
+  { lr | lg = lg + lg5, mlts = { mlts | x5 = mlts.x5 + 1 } }
+multLR7 : LogRep -> LogRep
+multLR7 ({ lg, mlts } as lr) =
+  { lr | lg = lg + lg7, mlts = { mlts | x7 = mlts.x7 + 1 } }
+showLogRep : LogRep -> String
+showLogRep lr =
+  let xpnd x m r =
+        if x <= 0 then r
+        else xpnd (shiftRightBy 1 x) (BigInt.mul m m)
+                  (if (and 1 x) /= 0 then BigInt.mul m r else r)
+  in BigInt.fromInt 1 |> xpnd lr.mlts.x2 (BigInt.fromInt 2)
+       |> xpnd lr.mlts.x3 (BigInt.fromInt 3) |> xpnd lr.mlts.x5 (BigInt.fromInt 5)
+       |> xpnd lr.mlts.x7 (BigInt.fromInt 7) |> BigInt.toString
+
+humblesLog : () -> CIS LogRep
+humblesLog() =
+  let prmfs = [multLR7, multLR5, multLR3, multLR2]
+      fprmf = List.head prmfs |> Maybe.withDefault identity -- never Nothing!
+      rstps = List.tail prmfs |> Maybe.withDefault [] -- never Nothing!
+      frstcis =
+        let nxt lr =
+              CIS lr <| \ _ -> nxt (fprmf lr)
+        in nxt (fprmf oneLogRep)
+      dflt = (0.0, Mults 0 0 0 0)
+      mkcis lrf cis =
+        let frst = lrf oneLogRep
+            scnd = lrf frst
+            nxt pq (CIS hd tlf as cs) =
+              let (lgv, v) = peekMinPQ pq |> Maybe.withDefault dflt in
+              if lgv < hd.lg then let lr = (LogRep lgv v) in CIS lr <| \ _ ->
+                   let { lg, mlts } = lrf lr
+                   in nxt (replaceMinPQ lg mlts pq) cs
+              else CIS hd <| \ _ ->
+                     let { lg, mlts } = lrf hd
+                     in nxt (pushPQ lg mlts pq) (tlf())
+        in CIS frst <| \ _ -> nxt (pushPQ scnd.lg scnd.mlts emptyPQ) cis
+      rest() = List.foldl mkcis frstcis rstps
+  in CIS oneLogRep <| \ _ -> rest()
+
+-- pretty printing function to add commas every 3 chars from left...
+comma3 : String -> String
+comma3 s =
+  let go n lst =
+        if n < 1 then String.join "," lst else
+        let nn = max (n - 3) 0
+        in go nn (String.slice nn n s :: lst)
+  in go (String.length s) []
+
+humbleDigitCountsTo : Int -> CIS LogRep -> List String
+humbleDigitCountsTo n cis =
+  let go i (CIS hd tlf) cnt cacc lst =
+        if i >= n then List.reverse lst else
+        if truncate hd.lg <= i then go i (tlf()) (cnt + 1) cacc lst
+        else let ni = i + 1
+                 ncacc = cacc + cnt
+                 str =
+                   (String.padLeft 4 ' ' << String.fromInt) ni
+                   ++ (String.padLeft 14 ' ' << comma3 << String.fromInt) cnt
+                   ++ (String.padLeft 19 ' ' << comma3 << String.fromInt) ncacc
+          in go ni (tlf()) 1 ncacc (str :: lst) -- always > 1 per dgt
+  in go 0 cis 0 0 []
+
+-- code to do with testing...
+timemillis : () -> Task Never Int -- a side effect function
+timemillis() = now |> andThen (\ t -> succeed (posixToMillis t))
+
+test : () -> Cmd Msg
+test() =
+  let numdgt = 100
+      hdg1 = "The first 50 humble numbers are:  "
+      msg1 = humblesLog() |> takeCIS2String 50 showLogRep
+      hdg2 = "Count of humble numbers for each digit length 1-"
+                ++ String.fromInt numdgt ++ ":"
+      msg2 = "Digits       Count              Accum"
+  in timemillis()
+       |> Task.andThen (\ strt ->
+            let rslt = humblesLog() |> humbleDigitCountsTo numdgt
+            in timemillis()
+              |> Task.andThen (\ stop ->
+                   succeed (((hdg1 ++ msg1) :: "" :: hdg2 :: msg2 :: rslt)
+                     ++ ["Counting took " ++ String.fromInt (stop - strt)
+                        ++ " milliseconds."])))
+  |> perform Done
+
+-- following code has to do with outputting to a web page using MUV/TEA...
+type alias Model = List String
+
+type Msg = Done Model
+
+main : Program () Model Msg
+main = Browser.element
+  { init = \ _ -> ([], test())
+  , update = \ (Done mdl) _ -> (mdl, Cmd.none)
+  , subscriptions = \ _ -> Sub.none
+  , view = div [] << List.map (\ s ->
+       if s == "" then br [] []
+       else pre [] <| List.singleton <| text s)
+  }