lama_byterun/stdlib/Data.lama

-- Data.
-- (C) Dmitry Boulytchev, JetBrains Research, St. Petersburg State University, 2020
--
-- This unit provides a set of generic operations on data structures.

import Collection;
import Ref;

-- Generic comparison for shared/cyclic data structures

public fun trace (x) {
  fun tracerec (s, x) {
    case x of
      #val -> skip -- printf ("unboxed:%d;", x)
    | _ ->
       if memSet (s, x)
       then printf ("<knot: 0x%.8x>", x)
       else
         var s_ = addSet (s, x);
         printf ("[0x%.8x: ", x);
         case x of
           #array -> printf ("a; ")
         | #fun   -> printf ("f<0x%.8x>; ", x[0])
         | #sexp  -> printf ("s; ")
         | #str   -> printf ("c<%s>; ", x)
         esac;
         for var i = case x of #fun -> 1 | _ -> 0 esac;, i<x.length, i := i+1
         do
           tracerec (s_, x[i])
         od;
         printf ("]")
       fi
    esac
  }

  tracerec (emptySet (flatCompare), x)
}

public infix =?= at < (x, y) {
  var m = ref (emptyMap (flatCompare));

  fun alreadyEq (x, y) {
    fun find (x) {
      fun walk (r) {
        fun walkrec (p1, p2, r) {
          case p2 of
            [_] -> p2 [0] := r
          |  _  -> skip
          esac;
          
          case r of
            [#val] -> r
          | [x]    -> walkrec (r, p1, x)
          esac
        }

        walkrec ({}, {}, r)
      }
      
      case findMap (deref (m), x) of
        Some (r) -> Some (walk (r))
      | x        -> x
      esac
    }

    case [find (x), find (y)] of
      [None, None] ->
        var v = [1];
        m ::= addMap (addMap (deref (m), x, v), y, v);
        false
         
    | [None, Some (ry)] ->
        m ::= addMap (deref (m), x, ry);
        false
         
    | [Some (rx), None] ->
        m ::= addMap (deref (m), y, rx);
        false
        
    | [Some (rx), Some (ry)] ->
        if rx == ry
        then true
        else
          if rx[0] < ry[0]
          then
            ry [0] := ry [0] + rx [0];
            rx [0] := ry
          else
            rx [0] := rx [0] + ry [0];
            ry [0] := rx
          fi;
          false
        fi
    esac    
  }

  fun cmpargs (x, y, from) {
    var diff = x.length - y.length;

    for var i = from;, i < x.length && diff == 0, i := i + 1 do
      diff := cmprec (x[i], y[i]) 
    od;
    
    diff
  }
  
  fun cmprec (x, y) {
    if alreadyEq (x, y)
    then 0
    else
      var diff = x.kindOf - y.kindOf;
      
      if diff != 0 then diff
      else
        case x of
          #array -> cmpargs (x, y, 0)
        | #fun   -> if (diff := x[0] - y[0]) == 0
                    then cmpargs (x, y, 1)
                    else diff
                    fi
        | #sexp  -> if (diff := compareTags (x, y)) == 0
                    then cmpargs (x, y, 0)
                    else diff
                    fi
        | _      -> compare (x, y)
        esac
      fi
    fi
  }

  cmprec (x, y)  
}

-- Generic equaliry for shared/cyclic data structures
public infix === at == (x, y) {
  (x =?= y) == 0
}