(*
 * lablai - An ML Artificial Inteligence library
 * Copyright (C) 2006  Till Crueger
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)
 
(* File $RCSfile$ *)
(* last edited by $Author: till_crueger $ *)
(* $Date: 2008-01-13 03:46:55 +0100 (So, 13 Jan 2008) $, $Revision: 39 $ *)

type 'a examiner = 'a -> float;;

type 'a t = 'a -> 'a examiner list -> float list list -> ('a * float list list);;

type permutation = int -> unit -> int array;;

let id size () =
   Array.init size (fun i -> i);;
   
let shuffle size () =
   (* create a shuffled list of size ints *)
   let map = Array.init size (fun i -> i) in
   let swap i j arr =
      let helper = arr.(i) in
      arr.(i) <- arr.(j);
      arr.(j) <- helper;
   in
   for i = 0 to Array.length map -1 do
      swap i (Random.int (Array.length map)) map
   done;
   map
   ;;
   
let fixed_shuffle size =
   (* create a shuffled list of size ints *)
   let map = Array.init size (fun i -> i) in
   let swap i j arr =
      let helper = arr.(i) in
      arr.(i) <- arr.(j);
      arr.(j) <- helper;
   in
   for i = 0 to Array.length map -1 do
      swap i (Random.int (Array.length map)) map
   done;
   (fun () -> map)
   ;;
   
let empty =
   fun x _ g -> (x,g);;
   
let make_exam examiners student =
   List.map (fun examiner -> examiner student) examiners
   ;;

let make_teacher data permutation trainer =
   let perm = permutation (Array.length data) in
   (fun student examiners grades ->
      let perm = perm () in
      let res = Array.fold_left (fun s i -> trainer s data.(i)) student perm in
      let next_grades = make_exam examiners res in
      (res,next_grades :: grades)
   )
   ;;
   
let teacher_of_fun f =
   (fun student examiners grades ->
      let res = f student in
      let next_grades = make_exam examiners res in
      (res,next_grades :: grades)
   )
   ;;
   
let (|->) teacher1 teacher2 =
   (fun student examiners grades -> 
      let student,grades = teacher1 student examiners grades in
      teacher2 student examiners grades
   )
   ;;
   
let rec repeat teacher n =
   if n > 0 then
      (repeat teacher (n-1)) |-> teacher 
   else
      empty
   ;;
   
let callback_student f =
   (fun student _ grades -> f student; (student,grades))
   ;;

let callback_grades f =
   (fun student _ grades -> f grades; (student,grades))
   ;;
   
let callback_both f =
   (fun student _ grades -> f student grades; (student,grades))
   ;;

let reset_grades =
   (fun student _ _ -> (student,[]))
   ;;
   
let ignore_grades teacher = 
   (fun student examiners grades -> 
      let (res,_) = teacher student examiners grades in
      (res,grades)
   )
   ;;
   
let really_ignore_grades teacher =
   (fun student _ grades -> 
      let (res,_) = teacher student [] [] in
      (res,grades)
   )
   ;;
   
let teach_until_student predicate ?(max=0) teacher =
   let rec loop n student examiners grades =
      let (res,grades) = teacher student examiners grades in
      if (predicate res) || (max != 0 && n>max) then
         (res,grades)
      else
         loop (n+1) res examiners grades
   in
   loop 0
   ;;

let teach_until_grades predicate ?(max=0) teacher =
   let rec loop n student examiners grades =
      let (res,grades) = teacher student examiners grades in
      if (predicate grades) || (max != 0 && n>max) then
         (res,grades)
      else
         loop (n+1) res examiners grades
   in
   loop 0
   ;;
   
let teach_until_both predicate ?(max=0) teacher =
   let rec loop n student examiners grades =
      let (res,grades) = teacher student examiners grades in
      if (predicate res grades) || (max != 0 && n>max) then
         (res,grades)
      else
         loop (n+1) res examiners grades
   in
   loop 0
   ;;
   
let teach_sync event =
   (fun student _ grades ->
      Event.sync event;
      (student,grades)
   )
   ;;
   
let teach teacher student =
   let (student,_) = teacher student [] [] in
   student
   ;;
   
let teach_graded teacher examiners student =
   let (student,grades) = teacher student examiners [] in
   (student,List.rev grades)
   ;;
   
let make_strukture_exam exam_fun =
   exam_fun
   ;;
   
let make_data_exam exam_fun data =
   (fun s ->
      let sum = ref 0.0 in
      for i = 0 to Array.length data -1 do
         let res = (exam_fun s data.(i)) in 
         sum := !sum +. res;
      done;
      !sum /. float_of_int (Array.length data)
   );;
   
let print_grades grades =
   List.iter 
      (fun grades ->
         List.iter
            (fun x -> print_float x; print_string "; ")
            grades;
         print_string "\n"
      )
      grades
   ;;

(* 
 * $Log$
 * Revision 1.4  2008/01/13 02:46:55  till_crueger
 * - Added more types of special teachers to build more complex teaching tasks
 *
 * Revision 1.3  2008/01/12 14:17:21  till_crueger
 * - Changed teacher structure to add a framework for exams after each epoche
 *
 * Revision 1.2  2008/01/11 14:25:50  till_crueger
 * - Changed teacher Interface to be able to combine different teachers
 *
 * Revision 1.1  2007/12/17 23:27:29  till_crueger
 *
 * - Added generic teacher for all kinds of supervised learning mechanism
 *
 *)