Sébastien Ferré avatar Sébastien Ferré committed 18ca7da

Initial revision

Comments (0)

Files changed (1)

+
+open Monad
+
+class type ['a,'b] t =
+  object
+    method apply : 'a -> 'b MOption.t
+    method unapply : 'b -> 'a MOption.t
+  end
+
+
+(* isomorphisms algebra *)
+
+class ['a,'b] inverse (f : ('a,'b) t) : ['b,'a] t =
+  object
+    method apply = f#unapply
+    method unapply = f#apply
+  end
+let inverse f = new inverse f
+
+let id : ('a,'a) t =
+  object
+    method apply x = MOption.some x
+    method unapply x = MOption.some x
+  end
+
+class ['a,'b,'c] compose (g : ('b,'c) t) (f : ('a,'b) t) : ['a,'c] t =
+  object
+    method apply x = MOption.bind (f#apply x) g#apply
+    method unapply z = MOption.bind (g#unapply z) f#unapply
+  end
+let compose g f = new compose g f
+let seq f g = new compose g f
+
+class ['a,'b,'c,'d] prod (f : ('a,'b) t) (g : ('c,'d) t) : ['a * 'c, 'b * 'd] t =
+  object
+    method apply (a,c) =
+      MOption.bind (f#apply a) (fun b ->
+	MOption.bind (g#apply c) (fun d ->
+	  MOption.some (b,d)))
+    method unapply (b,d) =
+      MOption.bind (f#unapply b) (fun a ->
+	MOption.bind (g#unapply d) (fun c ->
+	  MOption.some (a,c)))
+  end
+let prod f g = new prod f g
+
+let assoc : ('a * ('b * 'c), ('a * 'b) * 'c) t =
+  object
+    method apply (a,(b,c)) = MOption.some ((a,b),c)
+    method unapply ((a,b),c) = MOption.some (a,(b,c))
+  end
+
+let comm : ('a * 'b, 'b * 'a) t =
+  object
+    method apply (a,b) = MOption.some (b,a)
+    method unapply (b,a) = MOption.some (a,b)
+  end
+
+let unit : ('a, 'a * unit) t =
+  object
+    method apply x = MOption.some (x,())
+    method unapply (x,()) = MOption.some x
+  end
+
+class ['a] elt (e : 'a) : [unit, 'a] t =
+  object
+    method apply _ = MOption.some e
+    method unapply x =
+      if x = e then MOption.some () else MOption.none
+  end
+let elt e = new elt e
+
+class ['a] subset (p : 'a -> bool) : ['a,'a] t =
+  object
+    method apply x =
+      if p x then MOption.some x else MOption.none
+    method unapply x =
+      if p x then MOption.some x else MOption.none
+  end
+let subset p = new subset p
+
+(* isomorphisms for lists *)
+
+let nil : (unit, 'a list) t =
+  object
+    method apply () = MOption.some []
+    method unapply = function
+      | [] -> MOption.some ()
+      | _ -> MOption.none
+  end
+
+let cons : ('a * 'a list, 'a list) t =
+  object
+    method apply (x,xs) = MOption.some (x::xs)
+    method unapply = function
+      | [] -> MOption.none
+      | x::xs -> MOption.some (x,xs)
+  end
+
+(* conversions *)
+
+let string_of_list : (char list, string) t =
+  object
+    method apply lc =
+      let n = List.length lc in
+      let s = String.make n ' ' in
+      ignore (List.fold_left (fun i c -> s.[i] <- c; i+1) 0 lc);
+      MOption.some s
+    method unapply s =
+      let lc = ref [] in
+      for i = String.length s - 1 downto 0 do
+	lc := s.[i] :: !lc
+      done;
+      MOption.some !lc
+  end
+
+let int_of_string : (string, int) t =
+  object
+    method apply s =
+      try MOption.some (int_of_string s)
+      with _ -> MOption.none
+    method unapply i =
+      MOption.some (string_of_int i)
+  end
+
+(* isomorphisms for either *)
+
+type ('a,'b) either = Left of 'a | Right of 'b
+
+let left : ('a, ('a,'b) either) t =
+  object
+    method apply x = MOption.some (Left x)
+    method unapply = function
+      | Left x -> MOption.some x
+      | _ -> MOption.none
+  end
+
+let right : ('b, ('a,'b) either) t =
+  object
+    method apply x = MOption.some (Right x)
+    method unapply = function
+      | Right x -> MOption.some x
+      | _ -> MOption.none
+  end
+
+let list_cases : ((unit, 'a * 'a list) either, 'a list) t =
+  object
+    method apply = function
+      | Left () -> MOption.some []
+      | Right (x,xs) -> MOption.some (x::xs)
+    method unapply = function
+      | [] -> MOption.some (Left ())
+      | x::xs -> MOption.some (Right (x,xs))
+  end
+
+(* small step abstract machine *)
+
+let rec driver (f : 'a -> 'a MOption.t) (state : 'a) : 'a =
+  match f state with
+  | Some state' -> driver f state'
+  | None -> state
+
+class ['a] iterate (step : ('a,'a) t) : ['a,'a] t =
+  object
+    method apply x = MOption.some (driver step#apply x)
+    method unapply y = MOption.some (driver step#unapply y)
+  end
+let iterate step = new iterate step
+
+let step (f : ('a * 'b, 'a) t) : ('a * 'b list, 'a * 'b list) t =
+  compose
+    (prod f id)
+    (compose
+       assoc
+       (prod id (inverse cons)))
+
+let fold_left (f : ('a * 'b, 'a) t) : ('a * 'b list, 'a) t =
+  compose
+    (inverse unit)
+    (compose
+       (prod id (inverse nil))
+       (iterate (step f)))
+
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.