sml-projects/src/gap_map.sml

signature GAP_MAP_PAIR =
sig
  type key
  type value

  val l: key * key -> bool
  val eq: key * key -> bool
  val g: key * key -> bool

  val maxNodeSize: int
end

signature GAP_MAP =
sig
  structure Fn: GAP_MAP_PAIR

  type t

  val empty: t
  val isEmpty: t -> bool

  val add: Fn.key * Fn.value * t -> t
  val remove: Fn.key * t -> t

  val get: Fn.key * t -> Fn.value option
  val min: t -> (Fn.key * Fn.value) option
  val max: t -> (Fn.key * Fn.value) option

  val moveToStart: t -> t
  val moveToEnd: t -> t
  val moveTo: Fn.key * t -> t
end

functor MakeGapMap(Fn: GAP_MAP_PAIR): GAP_MAP =
struct
  structure Fn = Fn

  type t =
    { leftKeys: Fn.key vector list
    , leftVals: Fn.value vector list
    , rightKeys: Fn.key vector list
    , rightVals: Fn.value vector list
    }

  val empty = {leftKeys = [], leftVals = [], rightKeys = [], rightVals = []}

  fun isEmpty ({leftKeys = [], rightKeys = [], ...}: t) = true
    | isEmpty _ = false

  fun isLessThanTarget (v1, v2) =
    Vector.length v1 + Vector.length v2 <= Fn.maxNodeSize

  fun reverseLinearSearch (pos, findNum, vec) =
    if pos < 0 then
      ~1
    else
      let
        val curNum = Vector.sub (vec, pos)
      in
        if Fn.l (findNum, curNum) then pos
        else reverseLinearSearch (pos - 1, findNum, vec)
      end

  fun forwardLinearSearch (pos, findNum, vec) =
    if pos = Vector.length vec then
      Vector.length vec
    else
      let
        val curNum = Vector.sub (vec, pos)
      in
        if Fn.g (findNum, curNum) then pos + 1
        else forwardLinearSearch (pos + 1, findNum, vec)
      end

  fun helpFindInsPos (findNum, vec, low, high, prevMid) =
    if high >= low then
      let
        val mid = low + ((high - low) div 2)
        val curNum = Vector.sub (vec, mid)
      in
        if Fn.eq (curNum, findNum) then
          mid
        else if Fn.l (curNum, findNum) then
          helpFindInsPos (findNum, vec, mid + 1, high, mid)
        else
          helpFindInsPos (findNum, vec, low, mid - 1, mid)
      end
    else
      let
        val curNum = Vector.sub (vec, prevMid)
      in
        if Fn.g (findNum, curNum) then
          forwardLinearSearch (prevMid, findNum, vec)
        else
          reverseLinearSearch (prevMid, findNum, vec)
      end

  fun findInsPos (findNum, vec) =
    if Vector.length vec = 0 then ~1
    else helpFindInsPos (findNum, vec, 0, Vector.length vec - 1, 0)

  fun insWithPos (vec, elem, insPos) =
    if insPos < 0 then
      Vector.concat [Vector.fromList [elem], vec]
    else if insPos = Vector.length vec then
      Vector.concat [vec, Vector.fromList [elem]]
    else
      let
        val elem = Vector.fromList [elem]
        val elem = VectorSlice.full elem

        val s2len = Vector.length vec - insPos
        val slice1 = VectorSlice.slice (vec, 0, SOME insPos)
        val slice2 = VectorSlice.slice (vec, insPos, SOME s2len)
      in
        VectorSlice.concat [slice1, elem, slice2]
      end

  fun consLeft (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals) =
    let
      val leftKeys = hdKeys :: leftKeys
      val leftVals = hdVals :: leftVals
    in
      { leftKeys = leftKeys
      , leftVals = leftVals
      , rightKeys = rightKeys
      , rightVals = rightVals
      }
    end

  fun concatLeft (hdKeys, hdVals, lkhd, lktl, lvhd, lvtl, rightKeys, rightVals) =
    let
      val leftKeys = Vector.concat [lkhd, hdKeys] :: lktl
      val leftVals = Vector.concat [lvhd, hdVals] :: lvtl
    in
      { leftKeys = leftKeys
      , leftVals = leftVals
      , rightKeys = rightKeys
      , rightVals = rightVals
      }
    end

  fun consRight (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals) =
    let
      val rightKeys = hdKeys :: rightKeys
      val rightVals = hdVals :: rightVals
    in
      { leftKeys = leftKeys
      , leftVals = leftVals
      , rightKeys = rightKeys
      , rightVals = rightVals
      }
    end

  fun concatRight (hdKeys, hdVals, leftKeys, leftVals, rkhd, rktl, rvhd, rvtl) =
    let
      val rightKeys = Vector.concat [hdKeys, rkhd] :: rktl
      val rightVals = Vector.concat [hdVals, rvhd] :: rvtl
    in
      { leftKeys = leftKeys
      , leftVals = leftVals
      , rightKeys = rightKeys
      , rightVals = rightVals
      }
    end

  fun tryJoinStartOfRight
    (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals) =
    case (rightKeys, rightVals) of
      (rkhd :: rktl, rvhd :: rvtl) =>
        if isLessThanTarget (rkhd, hdVals) then
          (* join to right *)
          concatRight
            (hdKeys, hdVals, leftKeys, leftVals, rkhd, rktl, rvhd, rvtl)
        else
          (* cannot join to left or right while staying in limit
           * so cons instead *)
          consRight (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
    | (_, _) =>
        consRight (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)

  fun tryJoinMaxSide (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals) =
    case (leftKeys, leftVals) of
      (lkhd :: lktl, lvhd :: lvtl) =>
        if isLessThanTarget (lkhd, hdVals) then
          (* join to left *)
          concatLeft
            (hdKeys, hdVals, lkhd, lktl, lvhd, lvtl, rightKeys, rightVals)
        else
          tryJoinStartOfRight
            (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
    | (_, _) =>
        tryJoinStartOfRight
          (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)

  fun isSliceLessThanTarget (v1, v2) =
    VectorSlice.length v1 + Vector.length v2 <= Fn.maxNodeSize

  fun joinSlices
    (lkhd, lvhd, rkhd, rvhd, leftKeys, leftVals, rightKeys, rightVals) =
    case (leftKeys, leftVals, rightKeys, rightVals) of
      (p_lkhd :: p_lktl, p_lvhd :: p_lvtl, p_rkhd :: p_rktl, p_rvhd :: p_rvtl) =>
        if isSliceLessThanTarget (lkhd, p_lkhd) then
          let
            val p_lkhd = VectorSlice.full p_lkhd
            val leftKeys = VectorSlice.concat [p_lkhd, lkhd] :: p_lktl
            val p_lvhd = VectorSlice.full p_lvhd
            val leftVals = VectorSlice.concat [p_lvhd, lvhd] :: p_lvtl
          in
            if isSliceLessThanTarget (rkhd, p_rkhd) then
              let
                val p_rkhd = VectorSlice.full p_rkhd
                val rightKeys = VectorSlice.concat [rkhd, p_rkhd] :: p_rktl
                val p_rvhd = VectorSlice.full p_rvhd
                val rightVals = VectorSlice.concat [rvhd, p_rvhd] :: p_rvtl
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightKeys
                }
              end
            else
              let
                val rightKeys = VectorSlice.vector rkhd :: rightKeys
                val rightVals = VectorSlice.vector rvhd :: rightVals
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightKeys
                }
              end
          end
        else
          let
            val leftKeys = VectorSlice.vector lkhd :: leftKeys
            val leftVals = VectorSlice.vector rvhd :: leftVals
          in
            if isSliceLessThanTarget (rkhd, p_rkhd) then
              let
                val p_rkhd = VectorSlice.full p_rkhd
                val rightKeys = VectorSlice.concat [rkhd, p_rkhd] :: p_rktl
                val p_rvhd = VectorSlice.full p_rvhd
                val rightVals = VectorSlice.concat [rvhd, p_rvhd] :: p_rvtl
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightKeys
                }
              end
            else
              let
                val rightKeys = VectorSlice.vector rkhd :: rightKeys
                val rightVals = VectorSlice.vector rvhd :: rightVals
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightKeys
                }
              end
          end

  fun insMiddle
    ( hdKeys
    , hdVals
    , insPos
    , newKey
    , newVal
    , leftKeys
    , leftVals
    , rightKeys
    , rightVals
    ) =
    (* insert in middle *)
    if Fn.eq (Vector.sub (hdKeys, insPos), newKey) then
      (* we already have this key so just update hdVals to have newVal 
       * at insPos *)
      let
        val hdVals =
          Vector.mapi (fn (idx, el) => if idx <> insPos then el else newVal)
            hdVals
      in
        tryJoinMaxSide
          (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
      end
    else if Vector.length hdKeys + 1 > Fn.maxNodeSize then
      let
        (* split into two vectors and join with new *)
        val lkhd = VectorSlice.slice (hdKeys, 0, SOME insPos)
        val lvhd = VectorSlice.slice (hdVals, 0, SOME insPos)

        val rhdLen = Vector.length hdKeys - insPos
        val rkhd = VectorSlice.slice (hdKeys, insPos, SOME rhdLen)
        val rvhd = VectorSlice.slice (hdVals, insPos, SOME rhdLen)

        (* add new key/new val to right *)
        val newKey = Vector.fromList [newKey]
        val rkhd = VectorSlice.concat [VectorSlice.full newKey, rkhd]
        val rkhd = VectorSlice.full rkhd

        val newVal = Vector.fromList [newVal]
        val rvhd = VectorSlice.concat [VectorSlice.full newVal, rkhd]
        val rvhd = VectorSlice.full rvhd
      in
        (* join both slices *)
        joinSlices
          (lkhd, lvhd, rkhd, rvhd, leftKeys, leftVals, rightKeys, rightVals)
      end
    else
      let
        (* insert without splitting *)
        val hdKeys = insWithPos (hdKeys, newKey, insPos)
        val hdVals = insWithPos (hdVals, newVal, insPos)
      in
        tryJoinMaxSide
          (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
      end

  fun insLeft (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals) =
    case (leftKeys, leftVals) of
      (lkhd :: lktl, lvhd :: lvtl) =>
        let
          val insPos = findInsPos (newKey, lkhd)
        in
          if insPos = ~1 then
            (* move leftwards, joining hd with right if possible *)
            (case (rightKeys, rightVals) of
               (rkhd :: rktl, rvhd :: rvtl) =>
                 if isLessThanTarget (lkhd, rkhd) then
                   let
                     val rightKeys = Vector.concat [lkhd, rkhd] :: rktl
                     val rightVals = Vector.concat [lvhd, rvhd] :: rvtl
                   in
                     insLeft (newKey, newVal, lktl, lvtl, rightKeys, rightVals)
                   end
                 else
                   insLeft
                     ( newKey
                     , newVal
                     , lktl
                     , lvtl
                     , lkhd :: rightKeys
                     , lvhd :: rightVals
                     )
             | (_, _) =>
                 insLeft
                   ( newKey
                   , newVal
                   , lktl
                   , lvtl
                   , lkhd :: rightKeys
                   , lvhd :: rightVals
                   ))
          else if insPos = Vector.length lkhd then
            (* insert at end *)
            if Vector.length lkhd + 1 > Fn.maxNodeSize then
              let
                val hdKeys = Vector.fromList [newKey]
                val hdVals = Vector.fromList [newVal]
              in
                tryJoinStartOfRight
                  (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
              end
            else
              let
                (* join to end without splitting *)
                val leftKeys =
                  Vector.concat [lkhd, Vector.fromList [newKey]] :: lktl
                val leftVals =
                  Vector.concat [lvhd, Vector.fromList [newVal]] :: lvtl
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightVals
                }
              end
          else
            insMiddle
              ( lkhd
              , lvhd
              , insPos
              , newKey
              , newVal
              , lktl
              , lvtl
              , rightKeys
              , rightVals
              )
        end
    | (_, _) =>
        let
          val hdKeys = Vector.fromList [newKey]
          val hdVals = Vector.fromList [newVal]
        in
          tryJoinStartOfRight
            (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
        end

  fun insRight (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals) =
    case (rightKeys, rightVals) of
      (rkhd :: rktl, rvhd :: rvtl) =>
        let
          val insPos = findInsPos (newKey, rkhd)
        in
          if insPos = Vector.length rkhd then
            (* move right, joining if possible while staying under maxNodeSize *)
            (case (leftKeys, leftVals) of
               (lkhd :: lktl, lvhd :: lvtl) =>
                 if isLessThanTarget (lkhd, rkhd) then
                   let
                     val leftKeys = Vector.concat [lkhd, rkhd] :: lktl
                     val leftVals = Vector.concat [lvhd, rvhd] :: lvtl
                   in
                     insRight (newKey, newVal, leftKeys, leftVals, rktl, rvtl)
                   end
                 else
                   let
                     val leftKeys = rkhd :: leftKeys
                     val leftVals = rvhd :: leftVals
                   in
                     insRight (newKey, newVal, leftKeys, leftVals, rktl, rvtl)
                   end
             | (_, _) =>
                 let
                   val leftKeys = rkhd :: leftKeys
                   val leftVals = rvhd :: leftVals
                 in
                   insRight (newKey, newVal, leftKeys, leftVals, rktl, rvtl)
                 end)
          else if insPos < 0 then
            (* insert at start *)
            if Vector.length rkhd + 1 > Fn.maxNodeSize then
              let
                (* hd is full so split *)
                val hdKeys = Vector.fromList [newKey]
                val hdVals = Vector.fromList [newVal]
              in
                tryJoinMaxSide
                  (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
              end
            else
              let
                (* join to start without splitting *)
                val rightKeys =
                  Vector.concat [Vector.fromList [newKey], rkhd] :: rktl
                val rightVals =
                  Vector.concat [Vector.fromList [newVal], rvhd] :: rvtl
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightVals
                }
              end
          else
            insMiddle
              ( rkhd
              , rvhd
              , insPos
              , newKey
              , newVal
              , leftKeys
              , leftVals
              , rktl
              , rvtl
              )
        end
    | (_, _) =>
        let
          val hdKeys = Vector.fromList [newKey]
          val hdVals = Vector.fromList [newVal]
        in
          tryJoinMaxSide
            (hdKeys, hdVals, leftKeys, leftVals, rightKeys, rightVals)
        end

  fun add (newKey, newVal, map as {leftKeys, leftVals, rightKeys, rightVals}: t) =
    (* look at elements to see which way to traverse *)
    case rightKeys of
      hd :: _ =>
        let
          val rfirst = Vector.sub (hd, 0)
        in
          if Fn.g (new, rfirst) then 
            insRight (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)
          else if Fn.l (new, rfirst) then 
            insLeft (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)
          else 
            map
        end
    | [] => insLeft (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)
end