Commits

Anonymous committed ebb6f04

init

Comments (0)

Files changed (6)

+^run.bat$
+~$
+^_build/
+\.(byte|native)$
+<*.ml> | <*.mli> : camlp4r
+<ops.ml> : -camlp4r, camlp4o
+(* License: GPL
+   Author: Dmitry Grebeniuk gdsfh1 gmail com
+*)
+
+(* not thread-safe, like the original Lazy module. *)
+
+module Make ( Label : sig type t; end )
+ :
+  sig
+
+    type t 'a =
+      { l : Label.t
+      ; v : Lazy.t 'a
+      }
+    ;
+
+    exception Cycle of list Label.t
+    ;
+
+    value force : t 'a -> 'a
+    ;
+
+  end
+ =
+  struct
+
+    type t 'a =
+      { l : Label.t
+      ; v : Lazy.t 'a
+      }
+    ;
+
+    exception Cycle of list Label.t
+    ;
+
+    value get_cycle ~vis =
+      match vis with
+      [ [] -> assert False
+      | [now :: prevs] ->
+          List.rev (inner ~acc:[now] ~prevs)
+          where rec inner ~acc ~prevs =
+            match prevs with
+            [ [] -> assert False
+            | [h :: t] ->
+                if h == now
+                then acc
+                else inner ~acc:[h :: acc] ~prevs:t
+            ]
+      ]
+    ;
+
+    value visited_labels_rev = ref []
+    ;
+
+    value force ll =
+      let () = visited_labels_rev.val :=
+        [ll.l :: visited_labels_rev.val] in
+      try
+        let r = Lazy.force ll.v in
+        ( visited_labels_rev.val := []
+        ; r
+        )
+      with
+      [ CamlinternalLazy.Undefined ->
+          let c = visited_labels_rev.val in
+          ( visited_labels_rev.val := []
+          ; raise (Cycle (get_cycle ~vis:c))
+          )
+      ]
+    ;
+
+  end
+;
+let some x = Some x
+
+(** пропустить значение последовательно через функции:
+    123 >> string_of_int >> print_string
+*)
+let ( >> ) x f = f x
+
+(** применить значение к функции:
+    print_string & string_of_int & 123
+
+    NB: оператор "&" является ключевым словом в jocaml
+
+    Если попробовать объявить "let ( $ ) f x = f x",
+    то полученный оператор будет левоассоциативным,
+    что нежелательно в данном случае.
+*)
+let ( & ) f x = f x
+
+(** композиция функций:
+    let print_int = print_string % string_of_int
+    let print_int = print_string $ string_of_int
+    let print_int_sum = print_string % string_of_int %% ( + )
+    let print_int_sum = print_string %% (string_of_int %% ( + ) )
+    let for_all pred = not % List.exists (not % pred)
+    let for_all2 pred = not %% List.exists2 (not %% pred)
+
+    Операторы левоассоциативны, у оператора ($) приоритет ниже,
+    чем у (%), и ниже, чем у арифметических операторов.
+*)
+let ( % ) f g = fun x -> f (g x)
+let ( $ ) = ( % )
+let ( %% ) f g = fun x y -> f (g x y)
+let ( %%% ) f g = fun x y z -> f (g x y z)
+
+(** применить инфиксную функцию:
+    123L /* Int64.add */ 234L
+*)
+let ( /* ) x y = y x
+let ( */ ) x y = x y
+
+
+(* Для удобного использования инфиксных операторов
+   существует отличное решение: pa_do
+   ( http://pa-do.forge.ocamlcore.org/ )
+   Если использовать его не можете, то в качестве
+   слабого подобия можно взять нижеследующие модули.
+   Их названия имеют вид "Тип1_as_тип2", и при открытии
+   такого модуля со значениями типа1 можно будет работать
+   теми операторами, которыми обычно работают со значениями
+   типа2.
+   Например,
+   let my_int64 =
+     let module M =
+       struct
+         open Int32_as_int
+         open Int64_as_float
+         let x = (Int64.of_int32 (123l + 234l)) +. 345L
+       end
+     in
+       M.x
+*)
+
+(* Замечание: для консистентности модули "Тип1_as_тип2"
+   всегда должны переопределять одни и те же операторы.
+*)
+
+(* todo: добавить в Int* операции mod, rem, битовые *)
+
+module Int_as_int =
+  struct
+    let ( + ) = Pervasives.( + )
+    let ( - ) = Pervasives.( - )
+    let ( * ) = Pervasives.( * )
+    let ( / ) = Pervasives.( / )
+    let ( ~- ) = Pervasives.( ~- )
+  end
+
+module Float_as_float =
+  struct
+    let ( +. ) = Pervasives.( +. )
+    let ( -. ) = Pervasives.( -. )
+    let ( *. ) = Pervasives.( *. )
+    let ( /. ) = Pervasives.( /. )
+    let ( ~-. ) = Pervasives.( ~-. )
+  end
+
+
+(** TODO core, pa_do, pa_openin *)
+
+module Int32_as_int =
+  struct
+    let ( + ) = Int32.add
+    let ( - ) = Int32.sub
+    let ( * ) = Int32.mul
+    let ( / ) = Int32.div
+    let ( ~- ) = Int32.neg
+  end
+
+module Int64_as_int =
+  struct
+    let ( + ) = Int64.add
+    let ( - ) = Int64.sub
+    let ( * ) = Int64.mul
+    let ( / ) = Int64.div
+    let ( ~- ) = Int64.neg
+  end
+
+module Int_as_float =
+  struct
+    let ( +. ) = Pervasives.( + )
+    let ( -. ) = Pervasives.( - )
+    let ( *. ) = Pervasives.( * )
+    let ( /. ) = Pervasives.( / )
+    let ( ~-. ) = Pervasives.( ~- )
+  end
+
+module Float_as_int =
+  struct
+    let ( + ) = Pervasives.( +. )
+    let ( - ) = Pervasives.( -. )
+    let ( * ) = Pervasives.( *. )
+    let ( / ) = Pervasives.( /. )
+    let ( ~- ) = Pervasives.( ~-. )
+  end
+
+module Int32_as_float =
+  struct
+    let ( +. ) = Int32.add
+    let ( -. ) = Int32.sub
+    let ( *. ) = Int32.mul
+    let ( /. ) = Int32.div
+    let ( ~-. ) = Int32.neg
+  end
+
+module Int64_as_float =
+  struct
+    let ( +. ) = Int64.add
+    let ( -. ) = Int64.sub
+    let ( *. ) = Int64.mul
+    let ( /. ) = Int64.div
+    let ( ~-. ) = Int64.neg
+  end
+
+module Int_as_int_overflow =
+  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
+  struct
+    exception Overflow
+
+    let ( + ) a b =
+      let c = a + b in
+      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
+
+    let ( - ) a b =
+      let c = a - b in
+      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
+
+    let ( * ) a b =
+      let c = a * b in
+      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
+      then c else raise Overflow
+
+    let ( / ) a b =
+      if a = min_int && b = -1 then raise Overflow else a / b
+
+    let ( ~- ) x =
+      if x <> min_int then -x else raise Overflow
+
+  end
+#! /usr/bin/env bash
+
+TARGET="tests.byte"
+rm -f "$TARGET" && ocamlbuild "$TARGET" && "./$TARGET"
+open Ops
+;
+
+open Printf
+;
+
+module StdLazy = Lazy
+;
+
+module Lazy = LazyLabelled.Make(struct type t = string; end)
+;
+
+
+type node_val =
+  { name : string
+  ; int_val : int
+  }
+;
+
+
+type node 'a =
+  { node_val : 'a
+  ; links : list int
+  }
+and nodes 'a = array (node 'a)
+;
+
+
+value recdata construct =
+  let res_ref = ref None in
+  let get_res () =
+    match res_ref.val with
+    [ None -> failwith "recdata: not inited yet"
+    | Some r -> r
+    ]
+  in
+  let res = construct get_res in
+  ( res_ref.val := Some res
+  ; res
+  )
+;
+
+
+value _closure_old func nodes =
+  recdata
+    (fun get_self ->
+       Array.map
+         (fun n ->
+            lazy
+              (
+              let self = get_self () in
+              List.fold_left
+                (fun acc link ->
+                   func acc (StdLazy.force self.(link))
+                )
+                n.node_val
+                n.links
+              )
+         )
+         nodes
+    )
+  >>
+  Array.map StdLazy.force
+;
+
+
+value closure func nodes =
+  let lazyres =
+  recdata
+    (fun get_self ->
+       Array.map
+         (fun n ->
+           { Lazy.l = n.node_val.name
+           ; v = lazy
+              (
+              let self = get_self () in
+              List.fold_left
+                (fun acc link ->
+                   func acc (Lazy.force self.(link))
+                )
+                n.node_val
+                n.links
+              )
+           }
+         )
+         nodes
+    )
+  in
+    Array.map Lazy.force lazyres
+;
+
+
+value sum nodes = closure
+  (fun a b ->
+     { int_val = a.int_val + b.int_val
+     ; name = a.name ^ "+" ^ b.name
+     }
+  )
+  nodes
+;
+
+
+value print_array a =
+  printf "[| %s |]\n" &
+    String.concat "; " &
+    Array.to_list &
+    Array.map (fun nv -> sprintf "%s=%i" nv.name nv.int_val) a
+;
+
+value do_test nodes =
+  try
+    print_array & sum nodes
+  with
+  [ Lazy.Cycle lst -> printf "cycle contains: %s.\n" &
+      String.concat ", " lst
+  ]
+;
+
+
+value test_gen testfunc arg exp =
+  ( printf "Expected: %s\nGot     : %!" exp
+  ; testfunc arg
+  ; printf "\n%!"
+  )
+;
+
+
+value test nodes exp =
+  test_gen do_test nodes exp
+;
+
+value good_nodes =
+  [| { node_val = { name = "A"; int_val = 1 }; links = [1; 2] }
+   ; { node_val = { name = "B"; int_val = 2 }; links = [2] }
+   ; { node_val = { name = "C"; int_val = 3 }; links = [] }
+   |]
+;
+
+value bad_nodes =
+  [| { node_val = { name = "A"; int_val = 1 }; links = [1; 2] }
+   ; { node_val = { name = "B"; int_val = 2 }; links = [2] }
+   ; { node_val = { name = "C"; int_val = 3 }; links = [1] }
+   |]
+;
+
+value () = test good_nodes "[| A+B+C+C=9; B+C=5; C=3 |]"
+;
+
+value () = test bad_nodes "cycle contains: B, C."
+;
+
+(***********************************************************)
+
+module Lstr = LazyLabelled.Make(struct type t = string; end);
+
+value rec x = { Lstr.l = "X"; v = lazy (1 + Lstr.force x) }
+;
+
+value force_and_ignore x =
+  try
+    ignore & Lstr.force x
+  with
+  [ Lstr.Cycle c ->
+      printf "cycle contains: %s.\n%!" &
+        String.concat ", " c
+  ]
+;
+
+
+value () = test_gen force_and_ignore x "cycle contains: X."
+;