Fix equality for integers and floats (#89)

mattwparas · web-flow · commit 851172e6c0aa · 2023-10-07T16:35:51.000-07:00
* fix equality for integers and floats

* remove warning

* handle more equality cases

* pointer equality on bignums
diff --git a/cogs/r5rs.scm b/cogs/r5rs.scm
@@ -190,6 +190,14 @@
 
 (check-equal? "equality with float and int" #f (equal? 2.0 2))
 
+(check-equal? "numeric equality with float and int" #t (= 1 1.0))
+
+(check-equal? "pointer equality with int and int" #t (eq? 1 1))
+
+(check-equal? "pointer equality with floats" #t (eq? 1.0 1.0))
+
+(check-equal? "numeric equality with float and float" #t (= 1.0 1.0))
+
 (skip-compile (check-equal #f (eqv? 2 2.0))
               ;; TODO: Add make-vector function
               (check-equal #t (equal? (make-vector 5 'a) (make-vector 5 'a))))
@@ -475,11 +483,13 @@
               ;                  (s a b c))))
               (check-equal 'ok
                            (let ()
-                             (let-syntax () (define internal-def 'ok))
+                             (let-syntax ()
+                               (define internal-def 'ok))
                              internal-def))
               (check-equal 'ok
                            (let ()
-                             (letrec-syntax () (define internal-def 'ok))
+                             (letrec-syntax ()
+                               (define internal-def 'ok))
                              internal-def)))
 
 ; TODO: This causes a free identifier error
diff --git a/cogs/sorting/trie-sort.scm b/cogs/sorting/trie-sort.scm
@@ -8,84 +8,77 @@
 
 ;; Throw in a mediocre flatten definition
 (define (flatten lst)
-  (cond ((null? lst) empty)
-        ((list? lst)
-         (append (flatten (car lst)) (flatten (cdr lst))))
-        (else (list lst))))
+  (cond
+    [(null? lst) empty]
+    [(list? lst) (append (flatten (car lst)) (flatten (cdr lst)))]
+    [else (list lst)]))
 
 ;; contract: (listof char?) (listof tries?) integer? -> (listof trie?)
 (define (create-children char-list lst prefix-chars)
-  (cond [(= (length char-list) 1)
-         (handle-last-letter char-list lst prefix-chars)]
-        [else ;; you are in the middle of the word
-         (handle-intern-letter char-list lst prefix-chars)]))
+  (cond
+    [(= (length char-list) 1) (handle-last-letter char-list lst prefix-chars)]
+    ;; you are in the middle of the word
+    [else (handle-intern-letter char-list lst prefix-chars)]))
 
 ;; contract: (listof char?) (listof trie?) integer? -> (listof trie?)
 (define (handle-last-letter char-list lst prefix-chars)
   (define char (first char-list))
-                                        ; (define next-prefix (append prefix-chars (list char)))
+  ; (define next-prefix (append prefix-chars (list char)))
   (define next-prefix (push-back prefix-chars char))
-  (cond [(empty? lst) ;; children are empty, return list of empty children
-         (list (trie char empty #t next-prefix))]
-        [(< char (trie-char (first lst))) ;; less than, put it to the left
-         (cons (trie char empty #t next-prefix) lst)]
-        [(= char (trie-char (first lst))) ;; equal, step down a level
-         (cons (trie char (trie-children (first lst)) #t next-prefix) (rest lst))]
-        [else ;; move to the right
-         (cons (first lst)
-               (create-children char-list (rest lst) prefix-chars))]))
+  (cond
+    ;; children are empty, return list of empty children
+    [(empty? lst) (list (trie char empty #t next-prefix))]
+    ;; less than, put it to the left
+    [(< char (trie-char (first lst))) (cons (trie char empty #t next-prefix) lst)]
+    [(equal? char (trie-char (first lst))) ;; equal, step down a level
+     (cons (trie char (trie-children (first lst)) #t next-prefix) (rest lst))]
+    ;; move to the right
+    [else (cons (first lst) (create-children char-list (rest lst) prefix-chars))]))
 
 ;; contract: (listof char?) (listof trie?) integer? -> (listof trie?)
 (define (handle-intern-letter char-list lst prefix-chars)
   (define char (first char-list))
-                                        ; (define next-prefix (append prefix-chars (list char)))
+  ; (define next-prefix (append prefix-chars (list char)))
   (define next-prefix (push-back prefix-chars char))
-  (cond [(empty? lst) ;; no children, pop off front and step down
-         (list (trie char (create-children
-                           (rest char-list) empty next-prefix) #f next-prefix))]
-        [(< char (trie-char (first lst))) ;; place where it is, pop off front and go
-         (cons (trie char (create-children
-                           (rest char-list) empty next-prefix) #f next-prefix) lst)]
-        [(= char (trie-char (first lst))) ;; equal, step down
-         (cons (trie char (create-children (rest char-list) (trie-children (first lst)) next-prefix)
-                     (trie-end-word? (first lst))
-                     (trie-word-up-to (first lst)))
-               (rest lst))]
-        [else ; move to the right
-         (cons (first lst)
-               (create-children char-list (rest lst) prefix-chars))]))
+  (cond
+    [(empty? lst) ;; no children, pop off front and step down
+     (list (trie char (create-children (rest char-list) empty next-prefix) #f next-prefix))]
+    [(< char (trie-char (first lst))) ;; place where it is, pop off front and go
+     (cons (trie char (create-children (rest char-list) empty next-prefix) #f next-prefix) lst)]
+    [(equal? char (trie-char (first lst))) ;; equal, step down
+     (cons (trie char
+                 (create-children (rest char-list) (trie-children (first lst)) next-prefix)
+                 (trie-end-word? (first lst))
+                 (trie-word-up-to (first lst)))
+           (rest lst))]
+    ; move to the right
+    [else (cons (first lst) (create-children char-list (rest lst) prefix-chars))]))
 
 ;; contract: trie? string? integer? -> trie?
 (define (insert root-trie word)
   (define char-list (string->list word))
-  (trie
-   (trie-char root-trie)
-   (create-children char-list (trie-children root-trie) empty)
-   (trie-end-word? root-trie)
-   (trie-word-up-to root-trie)))
+  (trie (trie-char root-trie)
+        (create-children char-list (trie-children root-trie) empty)
+        (trie-end-word? root-trie)
+        (trie-word-up-to root-trie)))
 
 ;; contract: trie? trie? -> boolean?
 (define (trie<? trie-node1 trie-node2)
   (< (trie-char trie-node1) (trie-char trie-node2)))
 
-
 ;; contract: trie? (listof string?) -> trie?
 (define (build-trie-from-list-of-words trie list-of-words)
   (cond
-   [(= (length list-of-words) 1)
-    (insert trie (first list-of-words))]
-   [else
-    (build-trie-from-list-of-words
-     (insert trie (first list-of-words))
-     (rest list-of-words))]))
+    [(= (length list-of-words) 1) (insert trie (first list-of-words))]
+    [else (build-trie-from-list-of-words (insert trie (first list-of-words)) (rest list-of-words))]))
 
 ;; ------------------ SORTING ---------------------- ;;
 
 (define (trie-sort list-of-words)
   (define new-trie (build-trie-from-list-of-words empty-trie list-of-words))
   (pre-order new-trie))
 
-                                        ;; THIS ONE WORKS (using con and flatten)
+;; THIS ONE WORKS (using con and flatten)
 ;; contract: trie? -> (listof string?)
 (define (pre-order trie-node)
   (if (trie-end-word? trie-node)
diff --git a/crates/steel-core/src/rvals.rs b/crates/steel-core/src/rvals.rs
@@ -69,6 +69,7 @@ use futures_util::future::Shared;
 use futures_util::FutureExt;
 
 use im_lists::list::List;
+use num::ToPrimitive;
 use steel_parser::tokens::MaybeBigInt;
 
 use self::cycles::CycleDetector;
@@ -1253,6 +1254,9 @@ impl SteelVal {
 
     pub(crate) fn ptr_eq(&self, other: &SteelVal) -> bool {
         match (self, other) {
+            // Integers are a special case of ptr eq -> if integers are equal? they are also eq?
+            (IntV(l), IntV(r)) => l == r,
+            (NumV(l), NumV(r)) => l == r,
             (BoolV(l), BoolV(r)) => l == r,
             (VectorV(l), VectorV(r)) => Gc::ptr_eq(l, r),
             (Void, Void) => true,
@@ -1279,6 +1283,7 @@ impl SteelVal {
             (MutFunc(l), MutFunc(r)) => *l as usize == *r as usize,
             (BuiltIn(l), BuiltIn(r)) => *l as usize == *r as usize,
             (MutableVector(l), MutableVector(r)) => Gc::ptr_eq(l, r),
+            (BigNum(l), BigNum(r)) => Gc::ptr_eq(l, r),
             (_, _) => false,
         }
     }
@@ -1627,6 +1632,46 @@ impl SteelVal {
 
 impl Eq for SteelVal {}
 
+fn integer_float_equality(int: isize, float: f64) -> bool {
+    let converted = float as isize;
+
+    if float == converted as f64 {
+        int == converted
+    } else {
+        false
+    }
+}
+
+fn bignum_float_equality(bigint: &Gc<num::BigInt>, float: f64) -> bool {
+    if float.fract() == 0.0 {
+        if let Some(promoted) = bigint.to_f64() {
+            promoted == float
+        } else {
+            false
+        }
+    } else {
+        false
+    }
+}
+
+#[steel_derive::function(name = "=", constant = true)]
+pub fn number_equality(left: &SteelVal, right: &SteelVal) -> Result<SteelVal> {
+    let result = match (left, right) {
+        (IntV(l), IntV(r)) => l == r,
+        (NumV(l), NumV(r)) => l == r,
+        (IntV(l), NumV(r)) | (NumV(r), IntV(l)) => integer_float_equality(*l, *r),
+        (BigNum(l), BigNum(r)) => l == r,
+        (BigNum(l), NumV(r)) | (NumV(r), BigNum(l)) => bignum_float_equality(l, *r),
+
+        // Should be impossible to have an integer and a bignum be the same value
+        (IntV(_), BigNum(_)) | (BigNum(_), IntV(_)) => false,
+
+        _ => stop!(TypeMismatch => "= expects two numbers, found: {:?} and {:?}", left, right),
+    };
+
+    Ok(SteelVal::BoolV(result))
+}
+
 // TODO add tests
 impl PartialEq for SteelVal {
     fn eq(&self, other: &Self) -> bool {
@@ -1636,6 +1681,10 @@ impl PartialEq for SteelVal {
             (BigNum(l), BigNum(r)) => l == r,
             // (NumV(l), NumV(r)) => l == r,
             (IntV(l), IntV(r)) => l == r,
+
+            // Floats shouls also be considered equal
+            (NumV(l), NumV(r)) => l == r,
+
             // (NumV(l), IntV(r)) => *l == *r as f64,
             // (IntV(l), NumV(r)) => *l as f64 == *r,
             (StringV(l), StringV(r)) => l == r,
diff --git a/crates/steel-core/src/steel_vm/contracts.rs b/crates/steel-core/src/steel_vm/contracts.rs
@@ -23,7 +23,7 @@ impl ContractedFunction {
         {
             let mut parent = self.contract.parent();
             while let Some(p) = parent {
-                println!("Applying parents");
+                // println!("Applying parents");
                 p.apply(&self.name, &self.function, &arguments, cur_inst_span, ctx)?;
 
                 parent = p.parent()
diff --git a/crates/steel-core/src/steel_vm/primitives.rs b/crates/steel-core/src/steel_vm/primitives.rs
@@ -26,7 +26,7 @@ use crate::{
         StreamOperations, SymbolOperations, VectorOperations,
     },
     rerrs::ErrorKind,
-    rvals::FromSteelVal,
+    rvals::{FromSteelVal, NUMBER_EQUALITY_DEFINITION},
     steel_vm::{
         builtin::{get_function_name, Arity},
         vm::threads::threading_module,
@@ -751,7 +751,11 @@ fn equality_module() -> BuiltInModule {
                 |a: &SteelVal, b: &SteelVal| a.ptr_eq(b)
             )),
         )
-        .register_value("=", SteelVal::FuncV(ensure_tonicity_two!(|a, b| a == b)));
+        .register_native_fn_definition(NUMBER_EQUALITY_DEFINITION);
+
+    // TODO: Replace this with just numeric equality!
+    // .register_value("=", SteelVal::FuncV(ensure_tonicity_two!(|a, b| a == b)));
+
     module
 }
 
diff --git a/crates/steel-core/src/tests/success/trie_sort.scm b/crates/steel-core/src/tests/success/trie_sort.scm

Original file line number	Diff line number	Diff line change
`@@ -23,7 +23,7 @@ impl ContractedFunction {`
`23`	`23`	`{`
`24`	`24`	`let mut parent = self.contract.parent();`
`25`	`25`	`while let Some(p) = parent {`
`26`		`- println!("Applying parents");`
	`26`	`+ // println!("Applying parents");`
`27`	`27`	`p.apply(&self.name, &self.function, &arguments, cur_inst_span, ctx)?;`
`28`	`28`
`29`	`29`	`parent = p.parent()`