c

32 files changed, 263 insertions, 24 deletions

diff --git a/algorithms/dune b/algorithms/dune
index c8d1ff3..a98c160 100644
--- a/algorithms/dune
+++ b/algorithms/dune
@@ -1,6 +1,6 @@
 (library
  (inline_tests)
  (name algorithms_lib)
- (libraries core owl common_lib)
+ (libraries core owl genetics_lib utils_lib structures_lib)
  (preprocess
   (pps ppx_inline_test ppx_jane)))
diff --git a/algorithms/pbil.ml b/algorithms/pbil.ml
index e69de29..63d8ee8 100644
--- a/algorithms/pbil.ml
+++ b/algorithms/pbil.ml
@@ -0,0 +1,69 @@
+open! Core
+open Genetics_lib
+open Utils_lib
+
+module Input = struct
+  type t =
+    { gene_length : int
+    ; population_size : int
+    ; learning_coef : float
+    ; mutation_p : float
+    ; mutation_disturbance_coef : float
+    ; evaluate : Individual.t -> float
+    ; termination_condition : Population.t -> iteration:int -> bool
+    }
+  [@@deriving sexp_of]
+end
+
+module Output = struct
+  type t =
+    { distribution : float array
+    ; population : Population.t
+    }
+  [@@deriving sexp_of]
+end
+
+let adjust_distribution distribution individual learning_coef =
+  Gene.iteri (Individual.gene individual) ~f:(fun i value ->
+    let p = distribution.(i) in
+    distribution.(i) <- Float.((p * (1. - learning_coef)) + (value * learning_coef)))
+;;
+
+let mutate_distribution distribution mutation_p mutation_disturbance_coef =
+  Array.map_inplace distribution ~f:(fun p ->
+    if Float.(Random.uniform_01 () >= mutation_p)
+    then p
+    else
+      Float.(
+        (p * (1. - mutation_disturbance_coef))
+        + (Random.coin_flip () * mutation_disturbance_coef)))
+;;
+
+let pbil
+  { Input.gene_length
+  ; population_size
+  ; learning_coef
+  ; mutation_p
+  ; mutation_disturbance_coef
+  ; evaluate
+  ; termination_condition
+  }
+  =
+  let distribution = Array.init gene_length ~f:(fun _ -> 0.5) in
+  let population = Population.random population_size ~gene_length in
+  let rec pbil_aux iteration distribution population =
+    match termination_condition population ~iteration with
+    | true -> distribution, population
+    | false ->
+      let best_individual = Population.best_individual population ~f:evaluate in
+      adjust_distribution distribution best_individual learning_coef;
+      mutate_distribution distribution mutation_p mutation_disturbance_coef;
+      let population =
+        List.init population_size ~f:(fun _ -> Individual.derive distribution)
+        |> Population.create_exn
+      in
+      pbil_aux (iteration + 1) distribution population
+  in
+  let distribution, population = pbil_aux 0 distribution population in
+  { Output.distribution; population }
+;;
diff --git a/algorithms/pbil.mli b/algorithms/pbil.mli
index 5260232..cea76bb 100644
--- a/algorithms/pbil.mli
+++ b/algorithms/pbil.mli
@@ -1,18 +1,25 @@
 open! Core
-
-module Gene : sig
-  type t = float array
-end
+open Genetics_lib
 
 module Input : sig
   type t =
-    { population_size : int64
-    ; evaluate_individual : Gene.t -> int64
-    ; termination_condition : Gene.t list -> iteration:int64 -> bool
+    { gene_length : int
+    ; population_size : int
+    ; learning_coef : float
+    ; mutation_p : float
+    ; mutation_disturbance_coef : float
+    ; evaluate : Individual.t -> float
+    ; termination_condition : Population.t -> iteration:int -> bool
     }
   [@@deriving sexp_of]
 end
 
 module Output : sig
-  type t = { distribution : float array }
+  type t =
+    { distribution : float array
+    ; population : Population.t
+    }
+  [@@deriving sexp_of]
 end
+
+val pbil : Input.t -> Output.t
diff --git a/algorithms/simulated_annealing.ml b/algorithms/simulated_annealing.ml
index 8efb714..dde6a17 100644
--- a/algorithms/simulated_annealing.ml
+++ b/algorithms/simulated_annealing.ml
@@ -1,6 +1,6 @@
 open! Core
 open Owl
-open Common_lib
+open Utils_lib
 
 type 'a input =
   { trials : int
diff --git a/common/gene.ml b/common/gene.ml
deleted file mode 100644
index 3ad2609..0000000
--- a/common/gene.ml
+++ /dev/null
@@ -1 +0,0 @@
-open! Core
diff --git a/common/gene.mli b/common/gene.mli
deleted file mode 100644
index 7f14c08..0000000
--- a/common/gene.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-open! Core
-
-type t = float array [@@deriving sexp]
diff --git a/common/genetics/dune b/common/genetics/dune
new file mode 100644
index 0000000..7edec9c
--- /dev/null
+++ b/common/genetics/dune
@@ -0,0 +1,6 @@
+(library
+ (inline_tests)
+ (name genetics_lib)
+ (libraries core owl owl-plplot curl utils_lib)
+ (preprocess
+  (pps ppx_inline_test ppx_jane)))
diff --git a/common/genetics/gene.ml b/common/genetics/gene.ml
new file mode 100644
index 0000000..fdba45e
--- /dev/null
+++ b/common/genetics/gene.ml
@@ -0,0 +1,12 @@
+open! Core
+open Owl
+
+type t = float array [@@deriving sexp]
+
+let create = Fn.id
+let of_list = Array.of_list
+let length = Array.length
+let fold = Array.fold
+let init length ~value = Array.init length ~f:(fun _ -> value)
+let random length = Array.init length ~f:(fun _ -> Stats.uniform_rvs ~a:0. ~b:1.)
+let iteri = Array.iteri
diff --git a/common/genetics/gene.mli b/common/genetics/gene.mli
new file mode 100644
index 0000000..e26c310
--- /dev/null
+++ b/common/genetics/gene.mli
@@ -0,0 +1,13 @@
+open! Core
+
+type t [@@deriving sexp]
+
+val create : float array -> t
+val of_list : float list -> t
+val length : t -> int
+val fold : t -> init:'a -> f:('a -> float -> 'a) -> 'a
+val init : int -> value:float -> t
+val iteri : t -> f:(int -> float -> unit) -> unit
+
+(** Create a random gene. *)
+val random : int -> t
diff --git a/common/genetics/genetics_lib.ml b/common/genetics/genetics_lib.ml
new file mode 100644
index 0000000..4e3f80b
--- /dev/null
+++ b/common/genetics/genetics_lib.ml
@@ -0,0 +1,3 @@
+module Gene = Gene
+module Population = Population
+module Individual = Individual
diff --git a/common/genetics/individual.ml b/common/genetics/individual.ml
new file mode 100644
index 0000000..bf08647
--- /dev/null
+++ b/common/genetics/individual.ml
@@ -0,0 +1,13 @@
+open! Core
+open Utils_lib
+
+type t = Gene.t [@@deriving sexp_of]
+
+let create = Fn.id
+let length = Gene.length
+let gene = Fn.id
+let random = Gene.random
+
+let derive distribution =
+  Array.map distribution ~f:(fun p -> Random.binary p) |> Gene.create |> create
+;;
diff --git a/common/genetics/individual.mli b/common/genetics/individual.mli
new file mode 100644
index 0000000..ba4ac1c
--- /dev/null
+++ b/common/genetics/individual.mli
@@ -0,0 +1,12 @@
+open! Core
+
+type t [@@deriving sexp_of]
+
+(* For now it's an identity function, but maybe later there will be need for some additional information. *)
+val create : Gene.t -> t
+val length : t -> int
+val gene : t -> Gene.t
+val random : int -> t
+
+(** Creates the individual based on the genes probabilities. Returns error if the array has wrong length. *)
+val derive : float array -> t
diff --git a/common/genetics/population.ml b/common/genetics/population.ml
new file mode 100644
index 0000000..76017ca
--- /dev/null
+++ b/common/genetics/population.ml
@@ -0,0 +1,68 @@
+open! Core
+
+type t = Individual.t list [@@deriving sexp_of]
+
+let create individuals =
+  match individuals with
+  | [] -> Or_error.error_s [%message "Cannot create an empty population."]
+  | fst :: rest ->
+    let length = Individual.length fst in
+    if List.for_all rest ~f:(fun ind -> Individual.length ind = length)
+    then Ok individuals
+    else
+      Or_error.error_s
+        [%message
+          "Not all individuals have the same length." (individuals : Individual.t list)]
+;;
+
+let create_exn individuals = create individuals |> Or_error.ok_exn
+
+let best_individual t ~f =
+  let rec best_individual_aux best_individual best_value = function
+    | [] -> best_individual
+    | individual :: rest ->
+      let value = f individual in
+      let best_individual, best_value =
+        if Float.(value > best_value)
+        then individual, value
+        else best_individual, best_value
+      in
+      best_individual_aux best_individual best_value rest
+  in
+  best_individual_aux (List.hd_exn t) 0. t
+;;
+
+let random length ~gene_length =
+  List.init length ~f:(fun _ -> Individual.create (Gene.random gene_length))
+;;
+
+let%expect_test "best_individual" =
+  let population =
+    [ [| 0.; 0.1; 0.2; 0.3 |]; [| 1.; 1.; 1.; 1. |]; [| 0.; 0.; 0.; 0. |] ]
+    |> List.map ~f:Gene.create
+    |> List.map ~f:Individual.create
+    |> create
+  and empty_population = create []
+  and different_lengths_population =
+    [ [| 1. |]; [| 1.; 2. |] ]
+    |> List.map ~f:Gene.create
+    |> List.map ~f:Individual.create
+    |> create
+  in
+  print_s [%sexp (population : t Or_error.t)];
+  print_s [%sexp (empty_population : t Or_error.t)];
+  print_s [%sexp (different_lengths_population : t Or_error.t)];
+  [%expect
+    {|
+    (Ok ((0 0.1 0.2 0.3) (1 1 1 1) (0 0 0 0)))
+    (Error "Cannot create an empty population.")
+    (Error
+     ("Not all individuals have the same length." (individuals ((1) (1 2))))) |}];
+  let population = Or_error.ok_exn population in
+  let best_ind =
+    best_individual population ~f:(fun ind ->
+      Gene.fold (Individual.gene ind) ~init:0. ~f:( +. ))
+  in
+  print_s [%sexp (best_ind : Individual.t)];
+  [%expect {| (1 1 1 1) |}]
+;;
diff --git a/common/genetics/population.mli b/common/genetics/population.mli
new file mode 100644
index 0000000..950984a
--- /dev/null
+++ b/common/genetics/population.mli
@@ -0,0 +1,10 @@
+open! Core
+
+type t [@@deriving sexp_of]
+
+(** Returns error if the list is empty. *)
+val create : Individual.t list -> t Or_error.t
+
+val create_exn : Individual.t list -> t
+val best_individual : t -> f:(Individual.t -> float) -> Individual.t
+val random : int -> gene_length:int -> t
diff --git a/common/structures/dune b/common/structures/dune
new file mode 100644
index 0000000..a2327d2
--- /dev/null
+++ b/common/structures/dune
@@ -0,0 +1,6 @@
+(library
+ (inline_tests)
+ (name structures_lib)
+ (libraries core owl owl-plplot curl)
+ (preprocess
+  (pps ppx_inline_test ppx_jane)))
diff --git a/common/permutation.ml b/common/structures/permutation.ml
index d74ae33..d74ae33 100644
--- a/common/permutation.ml
+++ b/common/structures/permutation.ml
diff --git a/common/permutation.mli b/common/structures/permutation.mli
index b076d9f..b076d9f 100644
--- a/common/permutation.mli
+++ b/common/structures/permutation.mli
diff --git a/common/structures/structures_lib.ml b/common/structures/structures_lib.ml
new file mode 100644
index 0000000..78b26d9
--- /dev/null
+++ b/common/structures/structures_lib.ml
@@ -0,0 +1 @@
+module Permutation = Permutation
diff --git a/common/curl_helper.ml b/common/utils/curl_helper.ml
index 730eaf8..730eaf8 100644
--- a/common/curl_helper.ml
+++ b/common/utils/curl_helper.ml
diff --git a/common/curl_helper.mli b/common/utils/curl_helper.mli
index 6ed67f1..6ed67f1 100644
--- a/common/curl_helper.mli
+++ b/common/utils/curl_helper.mli
diff --git a/common/dune b/common/utils/dune
index e7273d4..e43b627 100644
--- a/common/dune
+++ b/common/utils/dune
@@ -1,6 +1,6 @@
 (library
  (inline_tests)
- (name common_lib)
+ (name utils_lib)
  (libraries core owl owl-plplot curl)
  (preprocess
   (pps ppx_inline_test ppx_jane)))
diff --git a/common/log.ml b/common/utils/log.ml
index 2992378..2992378 100644
--- a/common/log.ml
+++ b/common/utils/log.ml
diff --git a/common/log.mli b/common/utils/log.mli
index 50230bf..50230bf 100644
--- a/common/log.mli
+++ b/common/utils/log.mli
diff --git a/common/plotting.ml b/common/utils/plotting.ml
index d4a8af3..d4a8af3 100644
--- a/common/plotting.ml
+++ b/common/utils/plotting.ml
diff --git a/common/plotting.mli b/common/utils/plotting.mli
index 8af5afa..8af5afa 100644
--- a/common/plotting.mli
+++ b/common/utils/plotting.mli
diff --git a/common/utils/random.ml b/common/utils/random.ml
new file mode 100644
index 0000000..b3fd05f
--- /dev/null
+++ b/common/utils/random.ml
@@ -0,0 +1,6 @@
+open! Core
+open Owl
+
+let uniform_01 () = Stats.uniform_rvs ~a:0. ~b:1.
+let binary p = if Float.(uniform_01 () < p) then 1. else 0.
+let coin_flip () = binary 0.5
diff --git a/common/utils/random.mli b/common/utils/random.mli
new file mode 100644
index 0000000..7eb339c
--- /dev/null
+++ b/common/utils/random.mli
@@ -0,0 +1,8 @@
+open! Core
+
+val uniform_01 : unit -> float
+
+(** Return 1 with probability p, 0 with probability 1 - p. *)
+val binary : float -> float
+
+val coin_flip : unit -> float
diff --git a/common/common_lib.ml b/common/utils/utils_lib.ml
index ac026a5..536bf64 100644
--- a/common/common_lib.ml
+++ b/common/utils/utils_lib.ml
@@ -1,4 +1,4 @@
-module Permutation = Permutation
-module Curl_helper = Curl_helper
-module Plotting = Plotting
 module Log = Log
+module Plotting = Plotting
+module Curl_helper = Curl_helper
+module Random = Random
diff --git a/qap/src/dune b/qap/src/dune
index a7bfdff..5be99d0 100644
--- a/qap/src/dune
+++ b/qap/src/dune
@@ -1,6 +1,14 @@
 (library
  (inline_tests)
  (name qap_lib)
- (libraries async core owl owl-plplot curl common_lib algorithms_lib)
+ (libraries
+  async
+  core
+  owl
+  owl-plplot
+  curl
+  utils_lib
+  structures_lib
+  algorithms_lib)
  (preprocess
   (pps ppx_inline_test ppx_jane)))
diff --git a/qap/src/main.ml b/qap/src/main.ml
index b7e2939..dfda915 100644
--- a/qap/src/main.ml
+++ b/qap/src/main.ml
@@ -3,7 +3,7 @@ open! Core
 let simulated_annealing_command =
   Command.basic_or_error
     ~summary:"simulated annealing"
-    (let%map_open.Command () = Common_lib.Log.set_level_via_param ()
+    (let%map_open.Command () = Utils_lib.Log.set_level_via_param ()
      and n = flag "n" (required int) ~doc:"INT Qap instance size"
      and trials = flag "trials" (required int) ~doc:"INT number of trials"
      and radius = flag "radius" (required int) ~doc:"INT radius"
@@ -14,7 +14,7 @@ let simulated_annealing_command =
 let random_sampling_command =
   Command.basic_or_error
     ~summary:"random sampling"
-    (let%map_open.Command () = Common_lib.Log.set_level_via_param ()
+    (let%map_open.Command () = Utils_lib.Log.set_level_via_param ()
      and n = flag "n" (required int) ~doc:"INT Qap instance size"
      and trials = flag "trials" (required int) ~doc:"INT number of trials" in
      fun () ->
diff --git a/qap/src/qap.ml b/qap/src/qap.ml
index 719f8d9..c52288d 100644
--- a/qap/src/qap.ml
+++ b/qap/src/qap.ml
@@ -1,5 +1,6 @@
 open! Core
-open Common_lib
+open Utils_lib
+open Structures_lib
 module Matrix = Owl_dense_matrix.Generic
 
 (* # Popularne instancje QAP wraz z dokładnym minimum funkcji celu *)
@@ -30,7 +31,7 @@ type t =
 
 let create ~url =
   Log.info_s [%message "Downloading QAP instance" url];
-  let%map.Or_error data = Common_lib.Curl_helper.get ~url in
+  let%map.Or_error data = Utils_lib.Curl_helper.get ~url in
   Log.info_s [%message "Downloaded QAP instance"];
   let lines = String.split_lines data in
   let size = List.hd_exn lines |> Int.of_string in
diff --git a/qap/src/qap.mli b/qap/src/qap.mli
index 48f26a5..5422256 100644
--- a/qap/src/qap.mli
+++ b/qap/src/qap.mli
@@ -1,5 +1,5 @@
 open! Core
-open Common_lib
+open Structures_lib
 
 type t