- Added type-safe modular arithmetic.

4 files changed, 324 insertions, 5 deletions

diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index 1c56f1cb9..80d672d67 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -12,6 +12,7 @@
        (time [instant]
              [duration]
              [date])
+       (math [modular])
        [macro]
        (macro [code]
               ["s" syntax #+ syntax: Syntax])
@@ -26,14 +27,14 @@
     (wrap (list (` (let [(~ g!compose) (:: (~! text.Monoid<Text>) (~' compose))]
                      ($_ (~ g!compose) (~+ fragments))))))))
 
-## [Formatters]
-(type: #export (Formatter a)
+## [Formats]
+(type: #export (Format a)
   {#.doc "A way to produce readable text from values."}
   (-> a Text))
 
 (do-template [<name> <type> <formatter>]
   [(def: #export <name>
-     (Formatter <type>)
+     (Format <type>)
      <formatter>)]
 
   [%b        Bool              (:: bool.Codec<Text,Bool> encode)]
@@ -55,8 +56,13 @@
   [%date     date.Date         (:: date.Codec<Text,Date> encode)]
   )
 
+(def: #export (%mod modular)
+  (All [m] (Format (modular.Mod m)))
+  (let [[_ modulus] (modular.un-mod modular)]
+    (:: (modular.Codec<Text,Mod> modulus) encode modular)))
+
 (def: #export (%list formatter)
-  (All [a] (-> (Formatter a) (Formatter (List a))))
+  (All [a] (-> (Format a) (Format (List a))))
   (function [values]
     (case values
       #.Nil
diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux
new file mode 100644
index 000000000..7618a3a55
--- /dev/null
+++ b/stdlib/source/lux/math/modular.lux
@@ -0,0 +1,167 @@
+(.module:
+  lux
+  (lux (control ["ex" exception #+ exception:]
+                ["p" parser]
+                [codec #+ Codec]
+                [monad #+ do])
+       (data ["e" error #+ Error]
+             [number "int/" Codec<Text,Int>]
+             [text "text/" Monoid<Text>]
+             (text ["l" lexer #+ Lexer]))
+       (type abstract)
+       (macro [code]
+              ["s" syntax #+ syntax:])
+       [math]))
+
+(exception: #export Zero-Cannot-Be-A-Modulus)
+(exception: #export Cannot-Equalize-Numbers)
+(exception: #export Incorrect-Modulus)
+
+(abstract: #export (Modulus m)
+  {#.doc "A number used as a modulus in modular arithmetic.
+          It cannot be 0."}
+  
+  Int
+
+  (def: #export (from-int value)
+    (Ex [m] (-> Int (Error (Modulus m))))
+    (if (i/= 0 value)
+      (#e.Error (Zero-Cannot-Be-A-Modulus ""))
+      (#e.Success (@abstraction value))))
+
+  (def: #export (to-int modulus)
+    (All [m] (-> (Modulus m) Int))
+    (|> modulus @representation))
+  )
+
+(def: #export (congruent? modulus reference sample)
+  (All [m] (-> (Modulus m) Int Int Bool))
+  (|> sample
+      (i/- reference)
+      (i/% (to-int modulus))
+      (i/= 0)))
+
+(syntax: #export (modulus [modulus s.int])
+  (case (from-int modulus)
+    (#e.Success _)
+    (wrap (list (` (e.assume (..from-int (~ (code.int modulus)))))))
+    
+    (#e.Error error)
+    (p.fail error)))
+
+(def: (i/mod (^|> modulus [to-int])
+             value)
+  (All [m] (-> (Modulus m) Int Int))
+  (let [raw (i/% modulus value)]
+    (if (i/< 0 raw)
+      (let [shift (if (i/< 0 modulus) i/- i/+)]
+        (|> raw (shift modulus)))
+      raw)))
+
+(def: intL
+  (Lexer Int)
+  (p.codec number.Codec<Text,Int>
+           (p.either (l.seq (l.one-of "-") (l.many l.decimal))
+                     (l.many l.decimal))))
+
+(abstract: #export (Mod m)
+  {#.doc "A number under a modulus."}
+  
+  {#remainder Int
+   #modulus (Modulus m)}
+
+  (def: #export (mod modulus)
+    (All [m] (-> (Modulus m) (-> Int (Mod m))))
+    (function [value]
+      (@abstraction {#remainder (i/mod modulus value)
+                     #modulus modulus})))
+
+  (def: #export (un-mod modular)
+    (All [m] (-> (Mod m) [Int (Modulus m)]))
+    (@representation modular))
+
+  (def: separator Text " mod ")
+
+  (struct: #export (Codec<Text,Mod> modulus)
+    (All [m] (-> (Modulus m) (Codec Text (Mod m))))
+
+    (def: (encode modular)
+      (let [[remainder modulus] (@representation modular)]
+        ($_ text/compose
+            (int/encode remainder)
+            separator
+            (int/encode (to-int modulus)))))
+
+    (def: (decode text)
+      (<| (l.run text)
+          (do p.Monad<Parser>
+            [[remainder _ _modulus] ($_ p.seq intL (l.this separator) intL)
+             _ (p.assert (Incorrect-Modulus
+                          ($_ text/compose
+                              "Expected modulus: " (int/encode (to-int modulus)) "\n"
+                              "  Actual modulus: " (int/encode _modulus) "\n"))
+                         (i/= (to-int modulus) _modulus))]
+            (wrap (mod modulus remainder))))))
+
+  (def: #export (equalize reference sample)
+    (All [r s] (-> (Mod r) (Mod s) (Error (Mod r))))
+    (let [[reference reference-modulus] (@representation reference)
+          [sample sample-modulus] (@representation sample)]
+      (if (i/= (to-int reference-modulus)
+               (to-int sample-modulus))
+        (#e.Success (@abstraction {#remainder sample
+                                   #modulus reference-modulus}))
+        (#e.Error (Cannot-Equalize-Numbers
+                   ($_ text/compose
+                       "Reference modulus: " (int/encode (to-int reference-modulus)) "\n"
+                       "   Sample modulus: " (int/encode (to-int sample-modulus)) "\n"))))))
+
+  (do-template [<name> <op>]
+    [(def: #export (<name> reference sample)
+       (All [m] (-> (Mod m) (Mod m) Bool))
+       (let [[reference _] (@representation reference)
+             [sample _] (@representation sample)]
+         (<op> reference sample)))]
+
+    [m/= i/=]
+    [m/< i/<]
+    [m/<= i/<=]
+    [m/> i/>]
+    [m/>= i/>=]
+    )
+
+  (do-template [<name> <op>]
+    [(def: #export (<name> param subject)
+       (All [m] (-> (Mod m) (Mod m) (Mod m)))
+       (let [[param modulus] (@representation param)
+             [subject _] (@representation subject)]
+         (@abstraction {#remainder (|> subject
+                                       (<op> param)
+                                       (i/mod modulus))
+                        #modulus modulus})))]
+
+    [m/+ i/+]
+    [m/- i/-]
+    [m/* i/*])
+  
+  (def: (i/gcd+ a b)
+    (-> Int Int [Int Int Int])
+    (if (i/= 0 a)
+      [0 1 b]
+      (let [[ak bk gcd] (i/gcd+ (i/% a b) a)]
+        [(i/- (i/* ak
+                   (i// a b))
+              bk)
+         ak
+         gcd])))
+
+  (def: #export (inverse modular)
+    (All [m] (-> (Mod m) (Maybe (Mod m))))
+    (let [[value modulus] (@representation modular)
+          _modulus (to-int modulus)
+          [vk mk gcd] (i/gcd+ value _modulus)
+          co-prime? (i/= 1 gcd)]
+      (if co-prime?
+        (#.Some (mod modulus vk))
+        #.None)))
+  )
diff --git a/stdlib/test/test/lux/math/modular.lux b/stdlib/test/test/lux/math/modular.lux
new file mode 100644
index 000000000..76d56cbc2
--- /dev/null
+++ b/stdlib/test/test/lux/math/modular.lux
@@ -0,0 +1,146 @@
+(.module:
+  lux
+  (lux (control [monad #+ do])
+       (data [product]
+             [bool "bool/" Eq<Bool>]
+             ["e" error]
+             text/format)
+       (math ["r" random]
+             ["/" modular])
+       (lang [type "type/" Eq<Type>]))
+  lux/test)
+
+(def: %3 (/.modulus 3))
+(def: Mod3 Type (type-of %3))
+
+(def: modulusR
+  (r.Random Int)
+  (|> r.int
+      (:: r.Monad<Random> map (i/% 1000))
+      (r.filter (|>> (i/= 0) not))))
+
+(def: valueR
+  (r.Random Int)
+  (|> r.int (:: r.Monad<Random> map (i/% 1000))))
+
+(def: (modR modulus)
+  (All [m] (-> (/.Modulus m) (r.Random [Int (/.Mod m)])))
+  (do r.Monad<Random>
+    [raw valueR]
+    (wrap [raw (/.mod modulus raw)])))
+
+(def: value
+  (All [m] (-> (/.Mod m) Int))
+  (|>> /.un-mod product.left))
+
+(def: (comparison m/? i/?)
+  (All [m]
+    (-> (-> (/.Mod m) (/.Mod m) Bool)
+        (-> Int Int Bool)
+        (-> (/.Mod m) (/.Mod m) Bool)))
+  (function [param subject]
+    (bool/= (m/? param subject)
+            (i/? (value param)
+                 (value subject)))))
+
+(def: (arithmetic modulus m/! i/!)
+  (All [m]
+    (-> (/.Modulus m)
+        (-> (/.Mod m) (/.Mod m) (/.Mod m))
+        (-> Int Int Int)
+        (-> (/.Mod m) (/.Mod m) Bool)))
+  (function [param subject]
+    (|> (i/! (value param)
+             (value subject))
+        (/.mod modulus)
+        (/.m/= (m/! param subject)))))
+
+(context: "Modular arithmetic."
+  (<| (times +100)
+      (do @
+        [_normalM modulusR
+         _alternativeM (|> modulusR (r.filter (|>> (i/= _normalM) not)))
+         #let [normalM (|> _normalM /.from-int e.assume)
+               alternativeM (|> _alternativeM /.from-int e.assume)]
+         [_param param] (modR normalM)
+         [_subject subject] (modR normalM)
+         #let [copyM (|> normalM /.to-int /.from-int e.assume)]]
+        ($_ seq
+            (test "Every modulus has a unique type, even if the numeric value is the same as another."
+                  (and (type/= (type-of normalM)
+                               (type-of normalM))
+                       (not (type/= (type-of normalM)
+                                    (type-of alternativeM)))
+                       (not (type/= (type-of normalM)
+                                    (type-of copyM)))))
+            
+            (test "Can extract the original integer from the modulus."
+                  (i/= _normalM
+                       (/.to-int normalM)))
+            
+            (test "Can compare mod'ed values."
+                  (and (/.m/= subject subject)
+                       ((comparison /.m/= i/=) param subject)
+                       ((comparison /.m/< i/<) param subject)
+                       ((comparison /.m/<= i/<=) param subject)
+                       ((comparison /.m/> i/>) param subject)
+                       ((comparison /.m/>= i/>=) param subject)))
+            
+            (test "Mod'ed values are ordered."
+                  (and (bool/= (/.m/< param subject)
+                               (not (/.m/>= param subject)))
+                       (bool/= (/.m/> param subject)
+                               (not (/.m/<= param subject)))
+                       (bool/= (/.m/= param subject)
+                               (not (or (/.m/< param subject)
+                                        (/.m/> param subject))))))
+            
+            (test "Can do arithmetic."
+                  (and ((arithmetic normalM /.m/+ i/+) param subject)
+                       ((arithmetic normalM /.m/- i/-) param subject)
+                       ((arithmetic normalM /.m/* i/*) param subject)))
+
+            (test "Can sometimes find multiplicative inverse."
+                  (case (/.inverse subject)
+                    (#.Some subject^-1)
+                    (|> subject
+                        (/.m/* subject^-1)
+                        (/.m/= (/.mod normalM 1)))
+                    
+                    #.None
+                    true))
+
+            (test "Can encode/decode to text."
+                  (let [(^open "mod/") (/.Codec<Text,Mod> normalM)]
+                    (case (|> subject mod/encode mod/decode)
+                      (#e.Success output)
+                      (/.m/= subject output)
+
+                      (#e.Error error)
+                      false)))
+
+            (test "Can equalize 2 moduli if they are equal."
+                  (case (/.equalize (/.mod normalM _subject)
+                                    (/.mod copyM _param))
+                    (#e.Success paramC)
+                    (/.m/= param paramC)
+
+                    (#e.Error error)
+                    false))
+
+            (test "Cannot equalize 2 moduli if they are the different."
+                  (case (/.equalize (/.mod normalM _subject)
+                                    (/.mod alternativeM _param))
+                    (#e.Success paramA)
+                    false
+
+                    (#e.Error error)
+                    true))
+
+            (test "All numbers are congruent to themselves."
+                  (/.congruent? normalM _subject _subject))
+
+            (test "If 2 numbers are congruent under a modulus, then they must also be equal under the same modulus."
+                  (bool/= (/.congruent? normalM _param _subject)
+                          (/.m/= param subject)))
+            ))))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 899582b54..1742334d8 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -56,6 +56,7 @@
                          ["_." regex]))
              ["_." math]
              (math ["_." random]
+                   ["_." modular]
                    (logic ["_." continuous]
                           ["_." fuzzy]))
              (macro ["_." code]
@@ -82,7 +83,6 @@
                      [html]
                      [css])
              (coll (tree ["tree_." parser])))
-       (math [random])
        [macro]
        (macro (poly [json]))
        (type [unit])