Oliver Gu avatar Oliver Gu committed 1c6d898

Initial commit

Comments (0)

Files changed (6)

+Small OCaml code examples.

merge_sort_cps/merge_sort_cps.ml

+(* Merge sort. *)
+
+let rec split = function
+  | [] | [_] as x -> (x, [])
+  | x :: y :: l ->
+    let (xs, ys) = split l in
+    (x :: xs, y :: ys)
+
+let _ = assert (split [1;2;3;4;5] = ([1;3;5], [2;4]))
+
+let rec merge xs ys = match (xs, ys) with
+  | (xs, []) -> xs
+  | ([], ys) -> ys
+  | (x :: xs, y :: ys) ->
+    if x < y
+    then x :: merge xs (y :: ys)
+    else y :: merge (x :: xs) ys
+
+let _ = assert (merge [1;3] [2;4] = [1;2;3;4])
+
+let rec sort = function
+  | [] | [_] as x -> x
+  | xs ->
+    let (us, vs) = split xs in
+    merge (sort us) (sort vs)
+
+let _ = assert (sort [3;4;1;2;5;7;6;9;8] = [1;2;3;4;5;6;7;8;9])
+
+let make_rev_list n =
+  let rec loop n k =
+    if n = 0 then k []
+    else loop (n - 1) (fun l -> k (n :: l))
+  in
+  loop n (fun x -> x)
+
+let _ = assert (make_rev_list 5 = [5;4;3;2;1])
+
+let test_with_stack_overflow () =
+  let big_list = make_rev_list 1_000_000 in
+  sort big_list
+
+(* CPS version of merge sort. *)
+
+let ($) f x = f x
+let id x = x
+
+let rec split_k l k = match l with
+  | [] | [_] as x -> k (x, [])
+  | x :: y :: l' ->
+    split_k l' $ fun (xs, ys) ->
+    k (x :: xs, y :: ys)
+
+let _ = assert (split_k [1;2;3;4;5] id = ([1;3;5], [2;4]))
+
+let rec merge_k xs ys k = match (xs, ys) with
+  | (xs, []) -> k xs
+  | ([], ys) -> k ys
+  | (x :: xs, y :: ys) ->
+    if x < y
+    then merge_k xs (y :: ys) $ fun l -> k (x :: l)
+    else merge_k (x :: xs) ys $ fun l -> k (y :: l)
+
+let _ = assert (merge_k [1;3] [2;4] id = [1;2;3;4])
+
+let rec sort_k l k = match l with
+  | [] | [_] as x -> k x
+  | xs ->
+    split_k xs $ fun (us, vs) ->
+    sort_k  us $ fun us_sorted ->
+    sort_k  vs $ fun vs_sorted ->
+    merge_k us_sorted vs_sorted k
+
+let _ = assert (merge_k [1;3] [2;4] id = [1;2;3;4])
+let _ = assert (sort_k [3;4;1;2;5;7;6;9;8] id = [1;2;3;4;5;6;7;8;9])
+
+let test_without_stack_overflow () =
+  let big_list = make_rev_list 1_000_000 in
+  sort_k big_list id

palindromes/palindromes.ml

+(* Trie-based palindrome search. *)
+
+module List = ListLabels
+
+module Trie : sig
+  type t
+  type word = char list
+
+  val empty : t
+  val insert : t -> word -> t
+  val member : t -> word -> bool
+
+  val of_words : word list -> t
+end = struct
+  type t = T of bool * arcs
+  and arcs = (char * t) list
+
+  type word = char list
+
+  let empty = T (false, [])
+
+  let rec insert t word =
+    match (word, t) with
+    | [], T (_, arcs) -> T (true, arcs)
+    | c :: cs, T (flag, arcs) ->
+      let s = match (try Some (List.assoc c arcs) with _ -> None) with
+        | None -> empty
+        | Some s -> s
+      in
+      T (flag, (c, insert s cs) :: List.remove_assoc c arcs)
+
+  let rec member t word =
+    let T (flag, arcs) = t in
+    match word with
+    | [] -> flag
+    | c :: cs ->
+      match (try Some (List.assoc c arcs) with _ -> None) with
+      | None -> false
+      | Some s -> member s cs
+
+  let of_words words = List.fold_left words ~init:empty ~f:insert
+end
+
+let explode s =
+  let cs = ref [] in
+  for i = String.length s - 1 downto 0 do
+    cs := s.[i] :: !cs
+  done;
+  !cs
+
+let implode l =
+  let s = String.create (List.length l) in
+  List.iteri l ~f:(fun i c -> s.[i] <- c);
+  s
+
+let palindromes l =
+  let trie = Trie.of_words (List.map l ~f:explode) in
+  List.filter l ~f:(fun s ->
+    let word = List.rev (explode s) in
+    Trie.member trie word)
+
+let word_list =
+  ["hannah"; "level"; "kinnikinnik"; "rotator"; "explosion"; "ocaml"]
+
+let expected =
+  ["hannah"; "level"; "kinnikinnik"; "rotator"]
+
+let _ = assert (palindromes word_list = expected)

parser_monad/_tags

+<parser_monad.ml>:     thread, package(core)
+<parser_monad.native>: thread, package(core)

parser_monad/parser_monad.ml

+(* A simple parser monad. *)
+
+open Core.Std
+
+module Conv : sig
+  val explode : string -> char list
+  val implode : char list -> string
+end = struct
+  let explode s =
+    String.foldi s ~init:[] ~f:(fun i cs c -> c :: cs)
+    |> List.rev
+
+  let implode l =
+    let s = String.create (List.length l) in
+    List.iteri l ~f:(fun i c -> s.[i] <- c);
+    s
+end
+open Conv
+
+module Parser : sig
+  type 'a t
+  include Monad.S with type 'a t := 'a t
+
+  val empty : _ list t
+
+  val (|.) : 'a list t -> 'a list t -> 'a list t
+  val (&.) : 'a list t -> 'a list t -> 'a list t
+  val star : 'a list t -> 'a list t
+
+  type word = char list
+  val char : char -> word t
+
+  val run : 'a t -> string -> ('a * word) option
+end = struct
+  module M = struct
+    type 'a t = word -> ('a * word) option
+    and word = char list
+
+    let bind p f = fun word ->
+      match p word with
+      | Some (a, rem) -> let q = f a in q rem
+      | None          -> None
+
+    let return a = fun word -> Some (a, word)
+  end
+  include M
+  include Monad.Make (M)
+
+  let map p ~f = fun word ->
+    match p word with
+    | Some (a, rem) -> Some (f a, rem)
+    | None          -> None
+
+  let (>>|) p f = map p ~f
+
+  let fail = fun _word -> None
+
+  let empty = return []
+
+  let ( |. ) p q = fun word ->
+    match p word with
+    | Some _ as x -> x
+    | None        -> q word
+
+  let ( &. ) p q =
+    p >>= fun xs ->
+    q >>= fun ys ->
+    return (xs @ ys)
+
+  let rec list p = many1 p |. empty
+  and many1 p = p >>= fun x -> list p >>| fun xs -> x :: xs
+
+  let star p = list p >>| List.concat
+
+  let terminal ~f = fun word ->
+    match word with
+    | [] -> None
+    | c :: cs -> if f c then Some ([c], cs) else None
+
+  let char c = terminal ~f:((=) c)
+
+  let run p s = p (explode s)
+end
+open Parser
+
+(* Regular expression for a number in BNF.
+
+   digit   ::= '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
+   digits  ::= digit digit*
+   optsign ::= '-' | '+' | empty
+   optfrac ::= ( '.' digit* ) | empty
+   optexp  ::= ( ( 'e' | 'E' ) optsign digits ) | empty
+   number  ::= digits optfrac optexp
+*)
+
+let zero    = char '0'
+let digit   = explode "123456789"
+              |> List.map ~f:char
+              |> List.fold ~init:zero ~f:(|.)
+let digits  = digit &. star digit
+let optsign = char '-' |. char '+' |. empty
+let optfrac = (char '.' &. star digit) |. empty
+let optexp  = ((char 'e' |. char 'E') &. optsign &. digits) |. empty
+let number  = digits &. optfrac &. optexp
+
+let expected = Some (['3'; '.'; '1'; '4'; 'e'; '-'; '1'; '2'], [])
+let _ = assert (Parser.run number "3.14e-12" = expected)
+(* A naive implementation of Landin's SECD machine *)
+
+type term =
+| LIT of int
+| VAR of name
+| LAM of name * term
+| APP of term * term
+and name = string
+
+type program = term
+
+module Env = struct
+  type ('name, 'value) t = ('name * 'value) list
+  let empty = []
+  let extend t name value = (name, value) :: t
+  let lookup t name = List.assoc name t
+end
+
+type value =
+| INT of int
+| PRIM of (value -> value)
+| CLOSURE of name * term * env
+and env = (name, value) Env.t
+
+type stack = value list
+
+type control = directive list
+and directive =
+| TERM of term
+| APPLY
+
+type dump =
+| DUMP of stack * env * control * dump
+| EMPTY
+
+let rec step stack env control dump = match stack, env, control, dump with
+  | a :: _, e, [], EMPTY ->
+    a
+  | a :: s, e, [], DUMP (s', e', c', d') ->
+    step (a :: s') e' c' d'
+  | s, e, TERM (LIT i) :: c, d ->
+    step (INT i :: s) e c d
+  | s, e, TERM (VAR n) :: c, d ->
+    step (Env.lookup e n :: s) e c d
+  | s, e, TERM (LAM (n, b)) :: c, d ->
+    step (CLOSURE (n, b, e) :: s) e c d
+  | s, e, TERM (APP (op, arg)) :: c, d ->
+    step s e (TERM arg :: TERM op :: APPLY :: c) d
+  | CLOSURE (n, b, e') :: a :: s, e, APPLY :: c, d ->
+    step [] (Env.extend e' n a) [TERM b] (DUMP (s, e, c, d))
+  | PRIM f :: a :: s, e, APPLY :: c, d ->
+    step (f a :: s) e c d
+  | _ -> failwith "step: wrong input"
+
+let run terms =
+  let succ = function
+    | INT n -> INT (n + 1)
+    | _ -> invalid_arg "succ: wrong input"
+  in
+  let init_env = Env.extend Env.empty "succ" (PRIM succ) in
+  let init_control = List.map (fun t -> TERM t) terms in
+  step [] init_env init_control EMPTY
+
+let _ = assert(run [APP (LAM ("x", APP (VAR "succ", VAR "x")), LIT 1)] = INT 2)
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.