POD -- TP1
Une solution
Le serveur graphique
(* ============================================================== *)
(* == POD 98-99 : E.Chailloux P.Manoury B.Pagano *)
(* -------------------------------------------------------------- *)
(* == Le serveur graphique : graphic_server.ml *)
(* ============================================================== *)
open Graphics
(* == Utilitaire de feneantise *)
let si = string_of_int
(* == Les requetes graphiques *)
class virtual graph_query =
object
method virtual draw : unit
end
class gq_clear =
object
inherit graph_query
method draw = clear_graph ()
end
class gq_line col (x1,y1) (x2,y2) =
object
inherit graph_query
method draw = set_color col; moveto x1 y1; lineto x2 y2 ;
end
class gq_disk col (x,y) r =
object
inherit graph_query
method draw = set_color col; fill_circle x y r;
end
(* -- La classe gq_kill est utiliser pour fermer le serveur *)
class gq_kill () =
object
inherit graph_query
method draw = failwith "gq_kill#draw : not an usable method"
end
(* -- "Constructeurs" pour chaque sous-classe de graph_query *)
let clear = new gq_clear
and line = new gq_line
and disk = new gq_disk
(* == Le serveur *)
open Event
class graph_server x y =
object (self)
(* canal sur lequel transitent les requetes graphiques *)
val sync_channel = (new_channel () : graph_query channel)
(* semaphore pour forcer le traitement sequentiel des requetes*)
val sem = Mutex.create ()
(* requete qui servira a terminer le serveur *)
val kill_signal = (new gq_kill () : graph_query)
(* flag indiquant si le serveur est en etat d'accepter une requete *)
val mutable flag_alive = false
initializer
(* boucle de reception et de traitement des requetes *)
let boucle_receive_treat () =
while true do
let gq = sync (receive sync_channel)
(* si la requete est kill on termine la boucle sinon on traite *)
in if gq==kill_signal then Thread.exit ()
else self#treat_query gq
done
in
open_graph (" " ^ (si x) ^ "x" ^ (si y)) ;
(* la boucle s'execute dans un autre processus *)
Thread.create boucle_receive_treat () ;
(* le serveur est operationnel *)
flag_alive <- true
method get_channel = sync_channel
method alive = flag_alive
method private treat_query gq=
(* les traitements effectifs des requetes s'effectuent
un apres l'autre *)
Mutex.lock sem; gq#draw; Mutex.unlock sem
method exit =
(* le seurveur est considere comme arreter *)
flag_alive <- false ;
(* on envoie le signal kill pour terminer la boucle de reception *)
sync (send sync_channel kill_signal) ;
close_graph ()
end
(* == le client graphique *)
class graph_client (c:#graph_server) =
object (self)
method send gq =
if c#alive then sync (send c#get_channel gq)
end
(* == Le serveur asynchrone *)
class enhanced_graph_server x y =
object (self)
inherit graph_server x y
(* un second canal pour les requetes asynchrones *)
val async_channel = new_channel ()
(* une pile FIFO pour stocker les requetes recues et non traitees *)
val mutable query_fifo = []
(* le traitement de cette pile est une section critique protegee *)
val async_sem = Mutex.create ()
val async_signal = Condition.create ()
initializer
(* boucle de reception des requetes asynchrones *)
let boucle_receive () =
while true do
let gq = sync (receive async_channel)
in
begin
(* empiler la requete : section critique*)
Mutex.lock async_sem ;
query_fifo <- query_fifo @ [gq] ;
Mutex.unlock async_sem ;
(* on reveille la boucle de traitement *)
Condition.signal async_signal ;
(* si la requete est kill on termine la boucle sinon on traite *)
(* NB: la requete kill est empilee pour terminer l'autre boucle *)
if gq==kill_signal then Thread.exit ()
end
done
(* boucle de traitement des requetes asynchrones*)
and boucle_treat () =
while true do
Mutex.lock async_sem ;
(* si la boucle est vide on libere le semaphore et on attend *)
(* le signal de reception d'une requete *)
while query_fifo = [] do
Condition.wait async_signal async_sem
done ;
(* si la requete est kill on termine sinon on traite *)
let gq = List.hd query_fifo
in if gq == kill_signal
then (Mutex.unlock async_sem ; Thread.exit () )
else
self#treat_query gq ;
query_fifo <- List.tl query_fifo ;
Mutex.unlock async_sem
done
in
Thread.create boucle_receive ();
Thread.create boucle_treat (); ()
method get_async_channel = async_channel
method exit =
flag_alive <- false ;
(* on envoie le signal kill sur les deux canaux *)
sync (send sync_channel kill_signal) ;
sync (send async_channel kill_signal) ;
close_graph ()
end
(* == Le client asyncrhone *)
class enhanced_graph_client (egs:#enhanced_graph_server) =
object
inherit graph_client egs
method async_send gq =
if egs#alive then sync (send egs#get_async_channel gq)
end
Mondes et robots de base
(* ============================================================== *)
(* == POD 98-99 : E.Chailloux P.Manoury B.Pagano *)
(* -------------------------------------------------------------- *)
(* == Mondes et robots de base : robot_def.ml *)
(* ============================================================== *)
(* == Utilitaires *)
(* -- Prend un predicat et une liste et rend la sous-liste des *)
(* elements satisfaisant le predicat. *)
let rec select pred = function [] -> []
| a::l -> let next = select pred l in if pred a then a::next else next
(* -- Extraire au hasard un element d'une liste *)
let random_list = function
[] -> failwith "random_list: bad argument"
| l -> List.nth l (Random.int (List.length l))
(* -- No comment *)
let cases_voisines (x,y) =
[ (x-1,y-1);(x-1,y);(x-1,y+1);(x,y-1);(x,y+1);(x+1,y-1);(x+1,y);(x+1,y+1) ]
(* == Monde et robots abstraits *)
(* -- La classe monde est parametree par le type de ses robots *)
class virtual ['a] mondeV hi li =
object (s)
(* un robot doit posseder les methodes get_pos et set_pos *)
constraint 'a = unit; .. >
val h = (hi:int)
val l = (li:int)
val mutable roblist = ([]:'a list)
method virtual is_legal : (int * int) -> bool
method virtual normalize : (int * int) -> int * int
method get_roblist = roblist
method get_dim = (h,l)
method enter r = roblist <- r::roblist
method exit r = roblist <- select (fun ro -> r<>ro) roblist
method is_free p =
List.for_all (fun r -> p <> s#normalize(r#get_pos)) roblist
method free_places pos =
let f p = let p1=s#normalize p in (s#is_free p1) && (s#is_legal p1)
in select f (cases_voisines pos)
end
(* -- Les robots sont parametres par un monde *)
class virtual ['a] robotV (xi,yi) (vxi, vyi)=
object
(* un monde doit posseder la methode get_roblist *)
constraint 'a =
val mutable x = (xi:int)
val mutable y = (yi:int)
val mutable vx = (vxi:int)
val mutable vy = (vyi:int)
method virtual next_position :'a -> (int * int)
method get_pos = (x,y)
method get_speed = (vx,vy)
method set_pos (nx,ny) = x<-nx ;y<-ny
method set_speed (nvx,nvy) = vx<-nvx;vy<-nvy
end
(* == Mondes concrets *)
(* -- Un monde plat *)
class ['a] monde_ferme h l =
object
inherit ['a] mondeV h l
method is_legal (a,b) = (a >= 0) && (a < l) && (b >= 0) && (b < h)
method normalize p = p
end
(* -- Un monde rond *)
class ['a] monde_rond h l =
object
inherit ['a] mondeV h l
method is_legal _ = true
method normalize (x,y) = ( x mod l , y mod h )
end
(* == Robots concrets *)
(* -- Classe utilitaire : commandes de mouvements du robot *)
class virtual ['a] robot_commandV p v =
object (self)
inherit ['a] robotV p v
method private go_right_45 =
if vx=0 then vx <- vy
else if vy=0 then vy <- (-vx)
else if vx*vy>0 then vy <- 0
else vx <- 0
method private go_left_45 =
if vx=0 then vx <- (-vy)
else if vy=0 then vy <- vx
else if vx*vy>0 then vx <- 0
else vy <- 0
method private go_right_90 = self#go_right_45 ; self#go_right_45
method private go_left_90 = self#go_left_45 ; self#go_left_45
end
(* -- Robot fixe *)
class ['a] robot_fixe p =
object
inherit ['a] robotV p (0,0)
method next_position p = (x,y)
end
(* -- Robot fou *)
class ['a] robot_fou p =
object (s)
inherit ['a] robotV p (0,0)
method next_position m =
let list_pos = m#free_places s#get_pos
in if list_pos = [] then s#get_pos else random_list list_pos
end
(* -- Robot fou, variante *)
class ['a] robot_fou_inertie p v =
object (s)
inherit ['a] robot_commandV p v
method next_position m =
( match Random.int 3 with
0 -> ()
| 1 -> s#go_left_45
| _ -> s#go_right_45 );
let npos = (x+vx,y+vy)
in if m#is_free npos && m#is_legal npos then npos else (x,y)
end
(* -- Robot poli *)
class ['a] robot_poli p v =
object (s)
inherit ['a] robot_commandV p v
method next_position m =
let rob_pos_list = List.map (fun r -> r#get_pos) m#get_roblist
in let voisin =
List.exists (fun p -> List.mem p rob_pos_list) (cases_voisines (x,y))
in if voisin then (x,y)
else let new_pos = (x+vx,y+vy)
in if m#is_legal new_pos && m#is_free new_pos then new_pos
else ( s#go_right_90 ; (x,y) )
end
(* -- Robot presse *)
class ['a] robot_presse p v =
object (s)
inherit ['a] robot_commandV p v
method next_position m =
let new_pos = (x+vx,y+vy)
in if m#is_legal new_pos && m#is_free new_pos then new_pos
else ( s#go_left_45 ; (x,y) )
end
(* -- Robot amical *)
class ['a] robot_amical p v (a:'a #robotV) =
object (s)
inherit ['a] robot_commandV p v
val mutable ami = a
method private est_eloigne r =
let (rx,ry) = r#get_pos in (abs (x-rx)) > 1 || (abs (y-ry)) > 1
method private nouvel_ami m =
let liste_possible = select s#est_eloigne m#get_roblist
in if liste_possible = [] then s
else random_list liste_possible
method private change_ami m = ami <- s#nouvel_ami m
method next_position m =
(if not (s#est_eloigne ami) then s#change_ami m );
let (ax,ay)=ami#get_pos
in let sign n = if n=0 then 0 else n / (abs n)
in vx <- sign (ax-x) ; vy <- sign (ay-y) ;
( x+vx , y+vy )
end
Affichages
(* ============================================================== *)
(* == POD 98-99 : E.Chailloux P.Manoury B.Pagano *)
(* -------------------------------------------------------------- *)
(* == Mondes et robots affichables : robot_display.ml *)
(* ============================================================== *)
open Robot_def
(* == Classes abstraites generiques *)
class virtual ['a] mondeV_displayV =
object
method virtual get_dim : int * int
method virtual get_roblist : 'a list
method virtual display : unit
end
class virtual ['a] robotV_displayV =
object
method virtual get_pos : int * int
method virtual get_speed : int * int
method virtual display : unit
end
(* == Affichage texte : restent abstraites *)
class virtual ['a] mondeV_txt () =
object (s)
inherit ['a] mondeV_displayV
method display =
(let (h,l) = s#get_dim in Printf.printf "\nLE MONDE : %d x %d\n" h l) ;
List.iter (fun r -> r#display) s#get_roblist ;
flush stdout
end
class virtual ['a] robotV_txt ident =
object (s)
inherit ['a] robotV_displayV
val id = ident
method display =
let (x,y) = s#get_pos
in Printf.printf " Robot (%s) : %d - %d\n" id x y
end
(* == Affichages graphiques : restent abstraites et *)
(* utilisent le serveur graphique) *)
open Graphics
open Graphic_server
class virtual ['a] mondeV_graph (gc:enhanced_graph_client) =
object (s)
inherit ['a] mondeV_displayV
initializer
gc#send clear ;
let (h,l) = s#get_dim in
for i=0 to h do gc#send (line black (0,i*25) (l*25,i*25)) done;
for i=0 to l do gc#send (line black (i*25,0) (i*25,h*25)) done;
method display = List.iter (fun r -> r#display) s#get_roblist ;
end
class virtual ['a] robotV_graph ident c (gc:enhanced_graph_client) =
object (s)
inherit ['a] robotV_displayV
val mutable lx = -1
val mutable ly = -1
val mutable lvx = 0
val mutable lvy = 0
val mutable col = c
method get_col = col
method set_col c = col <- c
method display =
let (x,y) = s#get_pos and (vx,vy) = s#get_speed
in
if (x=lx && y=ly && vx=lvx && vy=lvy) then () else
( if lx <> -1 then gc#send (disk background (lx*25+12,ly*25+12) 10) );
gc#send (disk col (x*25+12,y*25+12) 10) ;
gc#send (line black (x*25+12,y*25+12) (x*25+12+vx*6,y*25+12+vy*6)) ;
lx <- x ; ly <- y ; lvx <- lvy
end
(* == Mondes et robots concrets : par heritage multiple *)
(* -- Affichage texte *)
class ['a] ferme_txt hi li =
object
inherit ['a] monde_ferme hi li
inherit ['a] mondeV_txt ()
end
class ['a] poli_txt id p v =
object
inherit ['a] robot_poli p v
inherit ['a] robotV_txt id
end
class ['a] fixe_txt id p =
object
inherit ['a] robot_fixe p
inherit ['a] robotV_txt id
end
class ['a] fou_txt id p =
object
inherit ['a] robot_fou p
inherit ['a] robotV_txt id
end
class ['a] amical_txt id p v a=
object
inherit ['a] robot_amical p v a
inherit ['a] robotV_txt id
end
class ['a] fou2_txt id p v =
object
inherit ['a] robot_fou_inertie p v
inherit ['a] robotV_txt id
end
(* -- Affichage graphiques *)
class ['a] poli_graph id c p v gc =
object
inherit ['a] robot_poli p v
inherit ['a] robotV_graph id c gc
end
class ['a] fixe_graph id c p gc =
object
inherit ['a] robot_fixe p
inherit ['a] robotV_graph id c gc
end
class ['a] fou_graph id c p gc =
object
inherit ['a] robot_fou p
inherit ['a] robotV_graph id c gc
end
class ['a] amical_graph id c p v a gc =
object (s)
inherit ['a] robot_amical p v a
inherit ['a] robotV_graph id c gc as super
method display =
let (x,y)=s#get_pos
in super#display ; gc#send (disk ami#get_col (x*25+12,y*25+12) 4)
end
class ['a] fou2_graph id c p v gc =
object
inherit ['a] robot_fou_inertie p v
inherit ['a] robotV_graph id c gc
end
class ['a] presse_graph id c p v gc =
object
inherit ['a] robot_presse p v
inherit ['a] robotV_graph id c gc
end
Mondes actifs
Avec quelques exemples
(* ============================================================== *)
(* == POD 98-99 : E.Chailloux P.Manoury B.Pagano *)
(* -------------------------------------------------------------- *)
(* == Mondes actifs : robot_actif.ml *)
(* ============================================================== *)
open Robot_def
(* == Classe abstraite generique *)
class virtual ['a] mondeV_actifV =
object (s)
method private virtual move_robot : 'a -> unit
method virtual go : unit
end
(* == Monde actif concret : boucle simple d'activation *)
(* sequentielle des robots *)
class virtual ['a] mondeV_iteratif () =
object (s)
inherit ['a] mondeV_actifV
method private move_robot r =
let pos = s#normalize (r#next_position s)
in if (s#is_free pos && s#is_legal pos) then r#set_pos pos
method go = while true do List.iter s#move_robot s#get_roblist done
end
open Robot_display
(* -- Exemple : le monde ferme , actif et display en texte *)
class ['a] ferme_actif_txt hi li =
object (s)
inherit ['a] mondeV_iteratif () as super
inherit ['a] mondeV_txt ()
inherit ['a] monde_ferme hi li
(* un robot s'affiche a chaque deplacement *)
method private move_robot r = super#move_robot r ; s#display
end
(* Autre exemple : les mondes graphiques et iteratifs *)
class virtual ['a] mondeV_iteratif_graph gc =
object (s)
inherit ['a] mondeV_graph gc
inherit ['a] mondeV_iteratif () as super
method private move_robot r = super#move_robot r ; s#display ;
end
class ['a] ferme_actif_graph hi li gc =
object (s)
inherit ['a] mondeV_iteratif_graph gc
inherit ['a] monde_ferme hi li
end
Les robots concurrents (threads)
(* ============================================================== *)
(* == POD 98-99 : E.Chailloux P.Manoury B.Pagano *)
(* -------------------------------------------------------------- *)
(* == Robots concurrents : robot_concurrent.ml *)
(* ============================================================== *)
open Robot_def
open Robot_display
open Robot_actif
(* == Cree un 'thread' pour chaque robot, reste abstraite *)
class virtual ['a] mondeV_concur () =
object (s)
inherit ['a] mondeV_actifV as super
val sem = Mutex.create ()
initializer Mutex.lock sem
method private move_robot r =
let pos = s#normalize (r#next_position s)
in
Mutex.lock sem ;
(if (s#is_free pos && s#is_legal pos) then r#set_pos pos ) ;
Mutex.unlock sem;
method enter r =
Thread.create (fun () -> while true do s#move_robot r done) () ; ()
method go = Mutex.unlock sem
method stop = Mutex.try_lock sem ; ()
end
(* -- Monde plat graphique et concurrent *)
class ['a] ferme_concur_graph hi li gc =
object (s)
inherit ['a] mondeV_concur () as super_conc
inherit ['a] mondeV_graph gc
inherit ['a] monde_ferme hi li as super_fer
method private move_robot r =
super_conc#move_robot r ;
r#display ;
Thread.delay ((Random.float 0.3) +. 0.2)
method enter r = super_fer#enter r ; super_conc#enter r
end
Le Makefile
CFLAGS = -thread -custom
OFLAGS = -thread
LIB = unix.cma threads.cma graphics.cma
LIBX = unix.cmxa threads.cmxa graphics.cmxa
CLIB = -cclib -lthreads -cclib -lunix -cclib -lgraphics \
-cclib -L/usr/X11R6/lib -cclib -lX11
OLIB = -cclib -lthreadsnat -cclib -lunix -cclib -lpthread \
-cclib -lgraphics -cclib -L/usr/X11R6/lib -cclib -lX11
I=
###########################################################################
FILES = graphic_server.cmo robot_def.cmo robot_display.cmo \
robot_actif.cmo robot_concurrent.cmo \
test.cmo
OFILES= graphic_server.cmx robot_def.cmx robot_display.cmx \
robot_actif.cmx robot_concurrent.cmx \
test.cmx
###########################################################################
all: $(FILES)
opt: $(OFILES)
run: $(FILES)
ocamlc $I $(CFLAGS) -o run $(LIB) $(FILES) $(CLIB)
runopt: $(OFILES)
ocamlopt $I $(OFLAGS) -o runopt $(LIBX) $(OFILES) $(OLIB)
###########################################################################
clean::
rm -f *~ *.cm? *_ml.h *.o
rm -f run runopt
###########################################################################
robot_display.cmo: graphic_server.cmo robot_def.cmo
robot_display.cmx: graphic_server.cmx robot_def.cmx
robot_actif.cmo: robot_def.cmo robot_display.cmo
robot_actif.cmx: robot_def.cmx robot_display.cmx
robot_concurrent.cmo: robot_actif.cmo robot_def.cmo robot_display.cmo
robot_concurrent.cmx: robot_actif.cmx robot_def.cmx robot_display.cmx
test.cmo: graphic_server.cmo robot_actif.cmo robot_concurrent.cmo \
robot_display.cmo
test.cmx: graphic_server.cmx robot_actif.cmx robot_concurrent.cmx \
robot_display.cmx
# Default rules
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo:
ocamlc -c $I $(CFLAGS) $<
.mli.cmi:
ocamlc -c $I $(CFLAGS) $<
.ml.cmx:
ocamlopt -c $I $(OFLAGS) $<
Page initiale Maison
Page précédente POD