lama_byterun/stdlib/Collection.expr

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

import List;

fun insertColl (m, k, v, sort) {
  fun append (v, vs) {
    case sort of
      Map  -> v : vs
    | Set  -> v
    | Hash -> case find (fun (x) {x == v}, vs) of
                None -> v : vs
              | _    -> vs
	      esac
    esac
  }
  
  fun rot (left, node) {
    if left
    then case node of
           MNode (k, v, _, l, MNode (rk, rv, _, ll, rr)) ->
             MNode (rk, rv, 0, MNode (k, v, 0, l, ll), rr)
         esac
    else case node of
           MNode (k, v, _, MNode (lk, lv, _, 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 = compare (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, k, sort) {
  fun extract (vv) {
    case sort of
      Map -> case vv of v : _ -> Some (v) | _ -> None esac
    | Set -> Some (vv)
    esac
  }
  
  fun inner (m) {
    case m of
      {} -> None
    | MNode (kk, vv, _, l, r) ->
       local c = compare (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, k, sort) {
  fun delete (vs) {
    case sort of
      Map -> case vs of {} -> {} | _ : vv -> vv esac
    | Set -> false
    esac
  }
  
  fun inner (m) {
    case m of
      {} -> m
    | MNode (kk, vv, bf, l, r) ->
       local c = compare (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 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 structure
public fun emptyMemo () {
  [{}]
}

public fun lookupMemo (m, v) {
  skip  
}