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 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 = rightVals
                }
              end
            else
              let
                val rightKeys = VectorSlice.vector rkhd :: rightKeys
                val rightVals = VectorSlice.vector rvhd :: rightVals
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightVals
                }
              end
          end
        else
          let
            val leftKeys = VectorSlice.vector lkhd :: leftKeys
            val leftVals = VectorSlice.vector lvhd :: 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 = rightVals
                }
              end
            else
              let
                val rightKeys = VectorSlice.vector rkhd :: rightKeys
                val rightVals = VectorSlice.vector rvhd :: rightVals
              in
                { leftKeys = leftKeys
                , leftVals = leftVals
                , rightKeys = rightKeys
                , rightVals = rightVals
                }
              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, rvhd]
        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, {leftKeys, leftVals, rightKeys, rightVals}) =
    (* look at elements to see which way to traverse *)
    case rightKeys of
      hd :: _ =>
        let
          val rfirst = Vector.sub (hd, 0)
        in
          if Fn.l (newKey, rfirst) then
            insLeft (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)
          else
            insRight (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)
        end
    | [] => insLeft (newKey, newVal, leftKeys, leftVals, rightKeys, rightVals)

  fun getLeft (check, leftKeys, leftVals) =
    case (leftKeys, leftVals) of
      (lkhd :: lktl, lvhd :: lvtl) =>
        let
          val pos = findInsPos (check, lkhd)
        in
          if pos < 0 then
            getLeft (check, lktl, lvtl)
          else if pos = Vector.length lkhd then
            NONE
          else
            let
              val posEl = Vector.sub (lkhd, pos)
            in
              if Fn.eq (check, posEl) then SOME (Vector.sub (lvhd, pos))
              else NONE
            end
        end
    | (_, _) => NONE

  fun getRight (check, rightKeys, rightVals) =
    case (rightKeys, rightVals) of
      (rkhd :: rktl, rvhd :: rvtl) =>
        let
          val pos = findInsPos (check, rkhd)
        in
          if pos = Vector.length rkhd then
            getRight (check, rktl, rvtl)
          else if pos < 0 then
            NONE
          else
            let
              val posEl = Vector.sub (rkhd, pos)
            in
              if Fn.eq (check, posEl) then SOME (Vector.sub (rvhd, pos))
              else NONE
            end
        end
    | (_, _) => NONE

  fun get (check, {leftKeys, leftVals, rightKeys, rightVals}) =
    case (rightKeys, rightVals) of
      (rkhd :: _, rvhd :: _) =>
        let
          val first = Vector.sub (rkhd, 0)
        in
          if Fn.g (check, first) then getRight (check, rightKeys, rightVals)
          else if Fn.eq (check, first) then SOME (Vector.sub (rvhd, 0))
          else getLeft (check, leftKeys, leftVals)
        end
    | (_, _) => getLeft (check, leftKeys, leftVals)

  fun helpMoveToStart (leftKeys, leftVals, rightKeys, rightVals) =
    case (leftKeys, leftVals) of
      (lkhd :: lktl, lvhd :: lvtl) =>
        (case (rightKeys, rightVals) of
           (rkhd :: rktl, rvhd :: rvtl) =>
             if isLessThanTarget (lkhd, rvhd) then
               let
                 val rightKeys = Vector.concat [lkhd, rkhd] :: rktl
                 val rightVals = Vector.concat [lvhd, rvhd] :: rvtl
               in
                 helpMoveToStart (lktl, lvtl, rightKeys, rightVals)
               end
             else
               let
                 val rightKeys = lkhd :: rightKeys
                 val rightVals = lvhd :: rightVals
               in
                 helpMoveToStart (lktl, lvtl, rightKeys, rightVals)
               end
         | (_, _) =>
             let
               val rightKeys = lkhd :: rightKeys
               val rightVals = lvhd :: rightVals
             in
               helpMoveToStart (lktl, lvtl, rightKeys, rightVals)
             end)
    | (_, _) =>
        { leftKeys = leftKeys
        , leftVals = leftVals
        , rightKeys = rightKeys
        , rightVals = rightVals
        }

  fun moveToStart {leftKeys, leftVals, rightKeys, rightVals} =
    helpMoveToStart (leftKeys, leftVals, rightKeys, rightVals)

  fun helpMoveToEnd (leftKeys, leftVals, rightKeys, rightVals) =
    case (rightKeys, rightVals) of
      (rkhd :: rktl, rvhd :: rvtl) =>
        (case (leftKeys, leftVals) of
           (lkhd :: lktl, lvhd :: lvtl) =>
             if isLessThanTarget (lkhd, rkhd) then
               let
                 val leftKeys = Vector.concat [lkhd, rkhd] :: leftKeys
                 val leftVals = Vector.concat [lvhd, rvhd] :: leftVals
               in
                 helpMoveToEnd (leftKeys, leftVals, rktl, rvtl)
               end
             else
               let
                 val leftKeys = rkhd :: leftKeys
                 val leftVals = rvhd :: leftVals
               in
                 helpMoveToEnd (leftKeys, leftVals, rktl, rvtl)
               end
         | (_, _) =>
             let
               val leftKeys = rkhd :: leftKeys
               val leftVals = rvhd :: leftVals
             in
               helpMoveToEnd (leftKeys, leftVals, rktl, rvtl)
             end)
    | (_, _) =>
        { leftKeys = leftKeys
        , leftVals = leftVals
        , rightKeys = rightKeys
        , rightVals = rightVals
        }

  fun moveToEnd {leftKeys, leftVals, rightKeys, rightVals} =
    helpMoveToEnd (leftKeys, leftVals, rightKeys, rightVals)

  fun moveLeft (to, leftKeys, leftVals, rightKeys, rightVals) =
    case (leftKeys, leftVals) of
      (lkhd :: lktl, lvhd :: lvtl) =>
        let
          val first = Vector.sub (lkhd, 0)
        in
          if Fn.l (to, first) then
            (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
                     moveLeft (to, lktl, lvtl, rightKeys, rightVals)
                   end
                 else
                   let
                     val rightKeys = lkhd :: rightKeys
                     val rightVals = lvhd :: rightVals
                   in
                     moveLeft (to, lktl, lvtl, rightKeys, rightVals)
                   end
             | (_, _) =>
                 let
                   val rightKeys = lkhd :: rightKeys
                   val rightVals = lvhd :: rightVals
                 in
                   moveLeft (to, lktl, lvtl, rightKeys, rightVals)
                 end)
          else
            { leftKeys = leftKeys
            , leftVals = leftVals
            , rightKeys = rightKeys
            , rightVals = rightVals
            }
        end
    | (_, _) =>
        { leftKeys = leftKeys
        , leftVals = leftVals
        , rightKeys = rightKeys
        , rightVals = rightVals
        }

  fun moveRight (to, leftKeys, leftVals, rightKeys, rightVals) =
    case (rightKeys, rightVals) of
      (rkhd :: rktl, rvhd :: rvtl) =>
        let
          val last = Vector.sub (rkhd, Vector.length rkhd - 1)
        in
          if Fn.g (to, last) then
            (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
                     moveRight (to, leftKeys, leftVals, rktl, rvtl)
                   end
                 else
                   let
                     val leftKeys = rkhd :: leftKeys
                     val leftVals = rvhd :: leftVals
                   in
                     moveRight (to, leftKeys, leftVals, rktl, rvtl)
                   end
             | (_, _) =>
                 let
                   val leftKeys = rkhd :: leftKeys
                   val leftVals = rvhd :: leftVals
                 in
                   moveRight (to, leftKeys, leftVals, rktl, rvtl)
                 end)
          else
            { leftKeys = leftKeys
            , leftVals = leftVals
            , rightKeys = rightKeys
            , rightVals = rightVals
            }
        end
    | (_, _) =>
        { leftKeys = leftKeys
        , leftVals = leftVals
        , rightKeys = rightKeys
        , rightVals = rightVals
        }

  fun moveToWhenRightIsEmpty
    (to, map as {leftKeys, leftVals, rightKeys, rightVals}) =
    case leftKeys of
      hd :: _ =>
        let
          val llast = Vector.sub (hd, Vector.length hd - 1)
        in
          if Fn.l (to, llast) then
            moveLeft (to, leftKeys, leftVals, rightKeys, rightVals)
          else
            map
        end
    | [] => map

  fun moveTo (to, map as {leftKeys, leftVals, rightKeys, rightVals}) =
    case rightKeys of
      hd :: _ =>
        let
          val rfirst = Vector.sub (hd, 0)
        in
          if Fn.l (to, rfirst) then
            moveLeft (to, leftKeys, leftVals, rightKeys, rightVals)
          else
            moveRight (to, leftKeys, leftVals, rightKeys, rightVals)
        end
    | [] => moveToWhenRightIsEmpty (to, map)
end