lama_byterun/stdlib/Collection.lama

-- Collections.
-- (C) Dmitry Boulytchev, JetBrains Research, St. Petersburg State University, 2020
--
-- This unit provides a simplistic implementation of immutable set/map/hashtable
-- data structures.

import List;
import Ref;

fun printColl (m) {
  fun inner (off, curr) {
    printf (off);
    case curr of
      {} -> printf ("** nil **\n")
    | MNode (k, v, b, l, r) ->
      printf ("** key = %s, bf = %d **\n", k.string, b);
      printf (off);
      printf ("   values :\n");
      iter (fun ([x, _]) {printf (off); printf ("             %s\n", x.string)}, v);
      inner ("  " ++ off, l);
      inner ("  " ++ off, r)
    esac
  }

  inner ("", m)
}

fun makeCompare (sort) {
  case sort of
    Hash -> fun (x, y) {
              if   x == y then 0
              elif x < y  then -1
              else 1
              fi
            }
  | _    -> compare
  esac
}

fun insertColl (m, pk, v, sort) {
  local compareKeys = makeCompare (sort),    
        k = case sort of Hash -> hash (pk) | _ -> pk esac;
  
  fun append (v, vs) {
    case sort of
      Map  -> v : vs
    | Set  -> v
    | Hash ->
       case find (fun (x) {compare (x, [pk, v]) == 0}, vs) of
         Some (_) -> vs
       | None     -> [pk, v] : vs
       esac
    esac
  }
  
  fun rot (left, node) {
    if left
    then case node of   
           MNode (k, v, b, l, MNode (rk, rv, rb, ll, rr)) ->
             MNode (rk, rv, 0, MNode (k, v, 0, l, ll), rr)
         esac
    else case node of
           MNode (k, v, b, MNode (lk, lv, lb, ll, rr), r) ->
             MNode (lk, lv, 0, ll, MNode (k, v, 0, rr, r))
         esac
    fi
  }

  fun factor (x) {x [2]}
  
  fun inner (m) {
    case m of
      {} -> [true, MNode (k, append (v, {}), 0, {}, {})]
    | MNode (kk, vv, bf, l, r) -> 
       local c = compareKeys (k, kk);
       if c == 0
       then [false, MNode (kk, append (v, vv), bf, l, r)]
       else if c < 0
            then
              case inner (l) of
                [true,  ll] -> if bf < 0
	                       then [false, MNode (kk, vv, bf + 1, ll, r)]
	                       elif bf == 1
			       then if ll.factor > 0
			            then [false, rot (false, MNode (kk, vv, bf, ll, r))]
			            else [false, rot (false, MNode (kk, vv, bf, rot (true, ll), r))]
			            fi
			       else [true,  MNode (kk, vv, bf + 1, ll, r)] 
			       fi
              | [false, ll] -> [false, MNode (kk, vv, bf, ll, r)]
	      esac		
            else
	      case inner (r) of
	        [true,  rr] -> if bf > 0
	                       then [false, MNode (kk, vv, bf - 1, l, rr)]
			       elif bf == -1
			       then if rr.factor < 0
			            then [false, rot (true, MNode (kk, vv, bf, l, rr))]
			            else [false, rot (true, MNode (kk, vv, bf, l, rot (false, rr)))]
			            fi				   
			       else [true,  MNode (kk, vv, bf - 1, l, rr)] 
			       fi
              | [false, rr] -> [false, MNode (kk, vv, bf, l, rr)]
	      esac
            fi
       fi	
    esac
  }

  inner (m).snd
} 

fun findColl (m, pk, sort) {
  local compareKeys = makeCompare (sort),  
        k = case sort of Hash -> hash (pk) | _ -> pk esac;
  
  fun extract (vv) {
    case sort of
      Map  -> case vv of v : _ -> Some (v) | _ -> None esac
    | Set  -> Some (vv)
    | Hash -> case find (fun (x) {compare (x.fst, pk) == 0}, vv) of
                Some (p) -> Some (p.snd)
              | None     -> None
              esac
    esac
  }
  
  fun inner (m) {
    case m of
      {} -> None
    | MNode (kk, vv, _, l, r) ->
       local c = compareKeys (k, kk);
       if c == 0
       then extract (vv)
       else inner (if c < 0 then l else r fi)
       fi
    esac
  }

  inner (m)
}

fun removeColl (m, pk, sort) {
  local compareKeys = makeCompare (sort),  
        k = case sort of Hash -> hash (pk) | _ -> pk esac;
  
  fun delete (vs) {
    case sort of
      Map  -> case vs of {} -> {} | _ : vv -> vv esac
    | Set  -> false
    | Hash -> remove (fun (x) {x.fst == pk}, vs)
    esac
  }
  
  fun inner (m) {
    case m of
      {} -> m
    | MNode (kk, vv, bf, l, r) ->
       local c = compareKeys (k, kk);
       if c == 0
       then MNode (kk, delete (vv), bf, l, r)
       else if c < 0
            then MNode (kk, vv, bf, inner (l), r)
            else MNode (kk, vv, bf, l, inner (r))
            fi
       fi
    esac
  }

  inner (m)
}

fun contents (m, sort) {
  fun append (k, vs, acc) {
    case sort of
      Map -> case vs of {} -> acc | v : _ -> [k, v] : acc esac
    | Set -> if vs then k : acc else acc fi
    esac
  }
  
  fun inner (m, acc) {
    case m of
      {} -> acc
    | MNode (k, vv, _, l, r) -> inner (l, append (k, vv, inner (r, acc))) 
    esac
  }

  inner (m, {})
}

public fun validateColl (t) {
  fun inner (t, verify) {
    case t of
      {} -> 0
    | MNode (k, _, bf, l, r) ->
       if verify (k)
       then
	 local lh = validateColl (l, fun (x) {x < k}),
	       rh = validateColl (r, fun (x) {x > k});

         if bf == lh - rh
	 then 1 + if lh > rh then lh else rh fi
	 else 1 + if lh > rh then lh else rh fi -- failure ("Collection::validateColl: balance violation on key %s\n", k.string)
	 fi
       else failure ("Collection::validateColl: order violation on key %s\n", k.string)
       fi
    esac
  }

  inner (t, fun (x) {true})
}

-- Map structure
public fun emptyMap () {
  {}
}

public fun addMap (m, k, v) {
  insertColl (m, k, v, Map)
}

public fun findMap (m, k) {
  findColl (m, k, Map)
}

public fun removeMap (m, k) {
  removeColl (m, k, Map)
}

public fun bindings (m) {
  contents (m, Map)
}

public fun listMap (l) {
  foldl (fun (m, p) {addMap (m, p.fst, p.snd)}, emptyMap (), l)
}

public fun iterMap (f, m) {
  iter (f, bindings (m))  
}

public fun mapMap (f, m) {
  listMap (map (fun (p) {[p.fst, f (p.snd)]}, bindings (m)))
}

public fun foldMap (f, acc, m) {
  foldl (f, acc, bindings (m))
}

-- Set structure
public fun emptySet () {
  {}
}

public fun addSet (s, v) {
  insertColl (s, v, true, Set)
}

public fun memSet (s, v) {
  case findColl (s, v, Set) of
    None     -> false
  | Some (f) -> f
  esac
}

public fun removeSet (s, v) {
  removeColl (s, v, Set)
}

public fun elements (m) {
  contents (m, Set)
}

public fun union (a, b) {
  foldl (addSet, a, elements (b))
}

public fun diff (a, b) {
  foldl (removeSet, a, elements (b))
}

public fun listSet (l) {
  foldl (addSet, emptySet (), l)
}

public fun iterSet (f, s) {
  iter (f, elements (s))  
}

public fun mapSet (f, s) {
  listSet (map (f, elements (s)))
}

public fun foldSet (f, acc, s) {
  foldl (f, acc, elements (s))
}

-- Hash consing
public fun emptyMemo () {
  ref ({})
}

public fun lookupMemo (m, v) {
  case v of
    #unboxed -> v
  | _ ->
     case findMap (deref (m), v) of
       Some (w) -> w
     | None ->
        case v of
          #string -> m ::= addMap (deref (m), v, v); v        
        | _ ->
          local vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;          
          for skip, i < v.length, i := i + 1 do
            local vci = lookupMemo (m, vc [i]);
            vc [i] := vci
          od;
          m ::= addMap (deref (m), vc, vc);
          vc
        esac
     esac
  esac
}

-- Maps of hashed pointers
public fun emptyHashTab () {
 {}
}

public fun addHashTab (t, k, v) {
  insertColl (t, k, v, Hash)
}

public fun findHashTab (t, k) {
  findColl (t, k, Hash)
}

public fun removeHashTab (t, k) {
  removeColl (t, k, Hash)
}