polymorphic intervals with abstract algebra and category theory

Intervals.ml

let ( or ) option default = Option.value option ~default

module Int = struct
  include Int

  let compare i1 i2 =
    let as_int = compare i1 i2 in
    if as_int > 0 then `Greater else if as_int < 0 then `Less else `Equal
  ;;

  let invert = neg
  let compose = add
  let identity = zero
  let successor = succ
end

type comparison =
  [ `Equal
  | `Greater
  | `Less
  ]

(* Abstract algebra boilerplate *)

module type MAGMA = sig
  type t

  val compose : t -> t -> t
end

module type UNITAL_MAGMA = sig
  type t

  include MAGMA with type t := t

  val identity : t
end

module type COUNTABLE_MAGMA = sig
  type t

  include UNITAL_MAGMA with type t := t

  val successor : t -> t
end

module type LOOP = sig
  type t

  include UNITAL_MAGMA with type t := t

  val invert : t -> t
end

module type COUNTABLE_LOOP = sig
  type t

  include LOOP with type t := t
  include COUNTABLE_MAGMA with type t := t
end

module type COMPARABLE = sig
  type t

  val compare : t -> t -> comparison
end

module type INTERVAL_ELEMENT = sig
  type t

  include COUNTABLE_LOOP with type t := t
  include COMPARABLE with type t := t
end

module Internal_function : sig
  (** Type of the function used on elements of the interval *)
  type 'a t = 'a -> 'a option

  val id : 'a t
  val compose : 'a t -> 'a t -> 'a t
end = struct
  type 'a t = 'a -> 'a option

  let id = fun x -> Some x
  let compose = fun g f x -> Option.bind (f x) g
end

module type INTERVAL = sig
  (** Type of some specialized interval *)
  type t

  type element

  val create : ?start:element -> element -> t
  val slope_of : t -> [ `Ascending | `Descending ]
  val map : (element -> element) -> t -> t
  val iter : (element -> unit) -> t -> unit
  val keep : (element -> bool) -> t -> t
  val discard : (element -> bool) -> t -> t
  val to_seq : t -> element Seq.t
  val to_list : t -> element list
end

(* TODO: support for [step_by] for [T]s that are quasigroups product-wise *)
(* TODO: support for interval composition [t -> t -> t option] *)
module Interval (T : INTERVAL_ELEMENT) : INTERVAL with type element = T.t = struct
  type t =
    { start : T.t
    ; stop : T.t
    ; func : T.t Internal_function.t
    }

  type element = T.t

  let create ?(start = T.identity) stop = { start; stop; func = Internal_function.id }

  let slope_of { start; stop } =
    match T.compare stop start with
    | `Equal | `Greater -> `Ascending
    | `Less -> `Descending
  ;;

  let map func range =
    { range with func = Internal_function.compose (fun x -> Some (func x)) range.func }
  ;;

  let iter func range =
    let _ =
      map
        (fun x ->
           let () = func x in
           x)
        range
    in
    ()
  ;;

  let keep func range =
    { range with
      func =
        Internal_function.compose (fun x -> if func x then Some x else None) range.func
    }
  ;;

  let discard func range = keep (Fun.negate func) range

  let rec to_seq ({ start; stop; func } as range) =
    let slope = slope_of range in
    let step =
      match slope with
      | `Ascending -> T.successor T.identity
      | `Descending -> T.invert (T.successor T.identity)
    in
    match T.compare start stop, slope with
    | (`Greater | `Equal), `Ascending | (`Less | `Equal), `Descending -> Seq.empty
    | _ ->
      let rest = to_seq { start = T.compose start step; stop; func } in
      (match func start with
       | None -> rest
       | Some start' -> Seq.cons start' rest)
  ;;

  let to_list range = range |> to_seq |> List.of_seq
end

module Range = struct
  include Interval (Int)

  module Notation = struct
    let ( %..< ) i1 i2 = create ~start:i1 i2
  end
end

open Range.Notation

let () =
  1 %..< 50
  |> Range.map (fun i -> (i * 2) - 1)
  |> Range.discard (fun i -> i mod 10 == 7)
  |> Range.keep (fun i -> i * 5 mod 6 > 4)
  |> Range.to_list
  |> List.map Int.to_string
  |> String.concat "; "
  |> Printf.printf "[ %s ]\n" (* [ 1; 13; 19; 25; 31; 43; 49; 55; 61; 73; 79; 85; 91 ] *)
;;