;;; Arl Standard Library - Equality and S3 Dispatch

(module equality
  (export identical?
          eq? eqv? equal?
          equal?.default equal?.environment equal?.list
          env-equal? list-equal?
          s3-type check-s3-type-match use-method set-method!)

  (import core :refer (r-call funcall get error))
  (import types :refer (environment? list? nil? null?))


  ;;' @section Equality Predicates
  ;;' Arl provides `equal?` for deep structural equality with S3-style dispatch,
  ;;' and `identical?` for R's native identity comparison. The Scheme predicates
  ;;' `eq?` and `eqv?` are intentionally not implemented because R does not
  ;;' provide the pointer-level semantics they require.

  ;;' @description Deep structural equality. Dispatches on class of
  ;;' first argument. Optional :strict #t uses identical? for atomics.
  ;;' Add methods with (set-method! 'equal? 'my-class (lambda (a b strict) ...)).
  ;;' @param a First value
  ;;' @param b Second value
  ;;' @param strict When #t, use identical? for atomics (default #f)
  ;;' @examples
  ;;' (equal? 1 1)                    ; => #t
  ;;' (equal? 1 1.0)                  ; => #t (type coercion)
  ;;' (equal? 1L 1.0 :strict #t)     ; => #f (strict mode, uses identical?)
  ;;' (equal? (list 1 2) (list 1 2))  ; => #t (deep structural)
  ;;' (equal? "hello" "hello")        ; => #t
  ;;' @assert
  ;;' (assert-true (equal? 1 1))
  ;;' (assert-true (equal? 1 1.0))
  ;;' (assert-false (equal? 1L 1.0 :strict #t))
  ;;' (assert-true (equal? (list 1 2) (list 1 2)))
  ;;' (assert-true (equal? "hello" "hello"))
  ;;' @seealso identical?, eq?, eqv?, set-method!
  (define equal?
    (lambda (a b (strict #f))
       (if (not (check-s3-type-match a b))
         #f
        (if (identical? a b)
          #t
          (use-method "equal?" a (list a b strict))))))

  ;;' @description R's native equality test. Structural comparison for value
  ;;'   types, pointer comparison for reference types.
  ;;' @param a First value
  ;;' @param b Second value
  ;;' @examples
  ;;' (identical? 1 1)          ; => #t
  ;;' (identical? 1L 1.0)       ; => #f (integer vs double)
  ;;' (identical? "a" "a")      ; => #t
  ;;' @assert
  ;;' (assert-true (identical? 1 1))
  ;;' (assert-false (identical? 1L 1.0))
  ;;' (assert-true (identical? "a" "a"))
  ;;' @seealso equal?, eq?, eqv?
  ;;' @note This is R's `identical()` with no modifications. Use `equal?`
  ;;'   for deep structural equality with type coercion.
  (define identical?
    (lambda (a b) (identical a b)))

  ;;' @description **Not implemented in Arl.** Raises an error when called.
  ;;' @param a First value
  ;;' @param b Second value
  ;;' @note True Scheme `eq?` semantics cannot be properly implemented in R because R does not provide reliable pointer equality for all object types. R's `identical()` does structural comparison for some types (lists, vectors) but pointer comparison for others (environments, reference classes). Use `identical?` for R's native equality, or `equal?` for deep structural equality.
  ;;' @seealso identical?, equal?
  (define eq?
    (lambda (a b)
      (error "eq? cannot be properly implemented in R. Use identical? for R's native equality, or equal? for deep structural equality.")))

  ;;' @description **Not implemented in Arl.** Raises an error when called.
  ;;' @param a First value
  ;;' @param b Second value
  ;;' @note True Scheme `eqv?` semantics cannot be properly implemented in R because R does not provide reliable pointer equality for all object types. Use `identical?` for R's native equality, or `equal?` for deep structural equality.
  ;;' @seealso identical?, equal?
  (define eqv?
    (lambda (a b)
      (error "eqv? cannot be properly implemented in R. Use identical? for R's native equality, or equal? for deep structural equality.")))

  ;;' @section Helper Functions for Equal?
  ;;' Internal helper functions used by the `equal?` dispatch methods to perform
  ;;' recursive structural comparison of environments and lists.

  ;;' @description Compare two environments by their bindings and values.
  ;;' @param env1 First environment
  ;;' @param env2 Second environment
  ;;' @examples
  ;;' (define e1 (new.env :parent (emptyenv)))
  ;;' (define e2 (new.env :parent (emptyenv)))
  ;;' (assign "x" 1 :envir e1)
  ;;' (assign "x" 1 :envir e2)
  ;;' (env-equal? e1 e2)              ; => #t
  ;;' @note Used internally by `equal?.environment`. Compares environments by sorting their bindings and recursively comparing values.
  ;;' @seealso equal?.environment
  (define env-equal?
    (lambda (env1 env2)
      (define names1 (_as-list (r-call "sort" (list (r-call "ls" (list env1 :all.names #t))))))
      (define names2 (_as-list (r-call "sort" (list (r-call "ls" (list env2 :all.names #t))))))
      (if (equal? names1 names2)
        ;; Same names - recursively compare values
        (begin
          (define result #t)
          (define n-names (length names1))
          (define ni 1)
          (while (and (<= ni n-names) result)
            (begin
              (if (not (equal? (r-call "get" (list ([[ names1 ni) :envir env1))
                               (r-call "get" (list ([[ names1 ni) :envir env2))))
                (set! result #f)
                #nil)
              (set! ni (+ ni 1))))
          result)
        #f)))

  ;;' @description Recursively compare list elements.
  ;;' @param lst1 First list
  ;;' @param lst2 Second list
  ;;' @examples
  ;;' (list-equal? (list 1 2 3) (list 1 2 3))  ; => #t
  ;;' (list-equal? (list 1 2) (list 1 2 3))     ; => #f
  ;;' (list-equal? (list 1 "a") (list 1 "a"))   ; => #t
  ;;' @assert
  ;;' (assert-true (list-equal? (list 1 2 3) (list 1 2 3)))
  ;;' (assert-false (list-equal? (list 1 2) (list 1 2 3)))
  ;;' (assert-true (list-equal? (list 1 "a") (list 1 "a")))
  ;;' @note Used internally by `equal?.list`. Recursively compares list elements using `equal?`.
  ;;' @seealso equal?.list
  (define list-equal?
    (lambda (lst1 lst2)
      (define n1 (length lst1))
      (define n2 (length lst2))
      (if (!= n1 n2) #f
        (begin
          (define result #t)
          (define i 1)
          (while (and (<= i n1) result)
            (if (not (equal? ([[ lst1 i) ([[ lst2 i)))
              (set! result #f))
            (set! i (+ i 1)))
          result))))

  ;;' @section S3 Dispatch System
  ;;' Arl implements a simplified S3-style dispatch system for generic functions
  ;;' like `equal?`. Types are identified by their first S3 class, and methods
  ;;' are registered as `generic.class` bindings in the top-level environment.

  ;;' @description Extract the first S3 class from an object.
  ;;' @param obj Object to get the S3 class of
  ;;' @examples
  ;;' (s3-type 42)                    ; => "numeric"
  ;;' (s3-type "hello")               ; => "character"
  ;;' (s3-type (list 1 2))            ; => "list"
  ;;' (s3-type (new.env))             ; => "environment"
  ;;' @assert
  ;;' (assert-equal "numeric" (s3-type 42))
  ;;' (assert-equal "character" (s3-type "hello"))
  ;;' (assert-equal "list" (s3-type (list 1 2)))
  ;;' (assert-equal "environment" (s3-type (new.env)))
  (define s3-type
    (lambda (obj)
      ([[ (class obj) 1)))

  ;;' @description Check if all objects have the same S3 type.
  ;;' @param obj First object
  ;;' @param rest Additional objects to compare against
  ;;' @examples
  ;;' (check-s3-type-match 1 2 3)     ; => #t (all numeric)
  ;;' (check-s3-type-match 1 "a")     ; => #f (numeric vs character)
  ;;' @assert
  ;;' (assert-true (check-s3-type-match 1 2 3))
  ;;' (assert-false (check-s3-type-match 1 "a"))
  ;;' @note Internal function used by `equal?` to verify type consistency before dispatch.
  (define check-s3-type-match
    (lambda (obj . rest)
      (begin
        (define type-a (s3-type obj))
        (if (== (length rest) 0)
          #t
          (begin
            (define cand-types (unique (lapply rest s3-type)))
            (if (> (length cand-types) 1)
              #f
              (begin
                (define type-b ([[ cand-types 1))
                (if (identical? type-a type-b)
                  #t
                  ;; integer and numeric are compatible in R
                  (if (and (r-call "is.numeric" (list obj))
                           (r-call "is.numeric" (list ([[ rest 1))))
                    #t
                    ;; list and call are compatible (quasiquote produces calls)
                    (if (and (r-call "is.recursive" (list obj))
                             (r-call "is.recursive" (list ([[ rest 1))))
                      #t
                      #f))))))))))

  ;;' @description Register an S3-style method.
  ;;' Example: (set-method! 'equal? 'my-class (lambda (a b strict) ...)).
  ;;' @param generic-name Symbol naming the generic function (e.g. 'equal?)
  ;;' @param class-name Symbol naming the S3 class to dispatch on
  ;;' @param method-fun Implementation function for this class
  ;;' @examples
  ;;' ;; Register a custom equality method for "point" objects:
  ;;' (set-method! 'equal? 'point
  ;;'   (lambda (a b strict)
  ;;'     (and (equal? ($ a "x") ($ b "x"))
  ;;'          (equal? ($ a "y") ($ b "y")))))
  ;;' @assert
  ;;' (set-method! 'equal? 'test-dummy (lambda (a b strict) #t))
  ;;' (assert-true (is.function (get "equal?.test-dummy" :envir (toplevel-env))))
  ;;' @seealso use-method
  (define set-method!
    (lambda (generic-name class-name method-fun)
      (define env (toplevel-env))
      (define method-name (paste0 (as.character generic-name) "." (as.character class-name)))
      (assign method-name method-fun :envir env)))

  ;;' @description Dispatch to an S3 method based on object class.
  ;;' @param generic-name String naming the generic (e.g. "equal?")
  ;;' @param obj Object whose class determines which method to call
  ;;' @param args List of arguments to pass to the method
  ;;' @note Internal function. Dispatches to the appropriate S3 method based on the object's class, falling back to the `.default` method if no class-specific method is found.
  ;;' @examples
  ;;' (use-method "equal?" (list 1 2) (list (list 1 2) (list 1 2) #f))  ; dispatches to equal?.list
  ;;' @assert
  ;;' (assert-true (use-method "equal?" (list 1 2) (list (list 1 2) (list 1 2) #f)))
  ;;' @seealso set-method!, s3-type
  (define use-method
    ; pass args explicitly because we can't use R's magic internals
    (lambda (generic-name obj args)
      (begin
        (define env (toplevel-env))
        (define class-name (s3-type obj))
        (define method-name (paste0 (as.character generic-name) "." class-name))
        (define method (get0 method-name :envir env :inherits #t))
        (if (nil? method)
          (set! method (get (paste0 (as.character generic-name) ".default") :envir env)))
        (funcall method args))))

  ;;' @section Built-in Equal? Methods
  ;;' These methods handle equality comparison for R's core types. The dispatch
  ;;' system selects the appropriate method based on the S3 class of the first
  ;;' argument. Users can register additional methods with `set-method!`.

  ;;' @description Default equality: atomic/vector comparison.
  ;;' :strict #t => #f; else use == with type coercion.
  ;;' @param a First value
  ;;' @param b Second value
  ;;' @param strict When #t, use identical? instead of == (default #f)
  ;;' @examples
  ;;' (equal?.default 1 1)             ; => #t
  ;;' (equal?.default 1 1.0)           ; => #t (coercion via ==)
  ;;' (equal?.default 1L 1.0 :strict #t) ; => #f (strict uses identical?)
  ;;' (equal?.default (c 1 2 3) (c 1 2 3))  ; => #t (element-wise)
  ;;' @assert
  ;;' (assert-true (equal?.default 1 1))
  ;;' (assert-true (equal?.default 1 1.0))
  ;;' (assert-false (equal?.default 1L 1.0 :strict #t))
  (define equal?.default
    (lambda (a b (strict #f))
      (begin
        (define comp-result (if strict (identical? a b) (r-call "==" (list a b))))
        (if (is.logical comp-result)
          (if (> (length comp-result) 1)
            (isTRUE (all comp-result))
            (isTRUE comp-result))
          #f))))

  ;;' @description Compare lists recursively by structure and elements.
  ;;' @param a First list
  ;;' @param b Second list
  ;;' @param strict When #t, use strict comparison (default #f)
  ;;' @examples
  ;;' (equal?.list (list 1 2 3) (list 1 2 3))          ; => #t
  ;;' (equal?.list (list 1 (list 2 3)) (list 1 (list 2 3)))  ; => #t (nested)
  ;;' (equal?.list (list 1 2) (list 1 2 3))             ; => #f
  ;;' @assert
  ;;' (assert-true (equal?.list (list 1 2 3) (list 1 2 3)))
  ;;' (assert-false (equal?.list (list 1 2) (list 1 2 3)))
  ;;' (assert-true (equal?.list (list 1 (list 2 3)) (list 1 (list 2 3))))
  (define equal?.list
    (lambda (a b (strict #f))
      (if (not (list? b))
        #f
        (list-equal? a b))))

  ;;' @description Compare environments by bindings and values
  ;;' (dict, set, R6, refclass are env-based).
  ;;' @param a First environment
  ;;' @param b Second environment
  ;;' @param strict When #t, use strict comparison (default #f)
  ;;' @examples
  ;;' (define e1 (new.env :parent (emptyenv)))
  ;;' (define e2 (new.env :parent (emptyenv)))
  ;;' (assign "x" 1 :envir e1)
  ;;' (assign "x" 1 :envir e2)
  ;;' (equal?.environment e1 e2)       ; => #t
  ;;' @assert
  ;;' (define _e1 (new.env :parent (emptyenv)))
  ;;' (define _e2 (new.env :parent (emptyenv)))
  ;;' (assign "x" 1 :envir _e1)
  ;;' (assign "x" 1 :envir _e2)
  ;;' (assert-true (equal?.environment _e1 _e2))
  (define equal?.environment
    (lambda (a b (strict #f))
      (if (not (environment? b))
        #f
        (env-equal? a b))))
)
