AeriesGuard Le Refuge des Créateurs Minecraftiens !

:: Utilisateurs Réfugiés SpiceGuid ► Jouons avec du (vrai) code OCaml

Version d'archive

  • Ce site est en lecture seule. Certains liens dynamiques peuvent ne pas fonctionner correctement.

Jouons avec du (vrai) code OCaml

Ce billet a pour but de tester la coloration du code OCaml sur Aerie's Guard. En grandeur nature.

Certains d'entre vous ont expérimenté avec Haskell .

Certains d'entre vous ont expérimenté avec OCaml ou suivent des cours OCaml .

Peut-être que certains d'entre vous suivent des cours Caml-Light .

Quoiqu'il en soit, avant de me lancer dans le grand bain, j'essaye d'abord le petit bassin.

En OCaml un module peut être un module-fonction , c'est-à-dire qu'il peut être paramétrable par un (ou plusieurs) module-argument (s) d'un certain module-type (s).

Donc la 1ière chose que nous allons faire c'est déclarer un module-type .

Il s'agit du type des ensembles totalement ordonnés implémentés comme des arbres binaires de recherche .

Mais on ne précise pas s'ils sont mutables ou immutables (on le fera plus tard).

(* Totally ordered Sets *)
module type OrderedSet =
   sig
      type 'a set =
         'a non_empty_set option
      and 'a non_empty_set =
         private
         {mutable left: 'a set; item: 'a; mutable right: 'a set}
      val empty : 'a set
      val make : 'a set -> 'a -> 'a set -> 'a non_empty_set
      val with_left  : 'a non_empty_set -> 'a set -> 'a non_empty_set
      val with_right : 'a non_empty_set -> 'a set -> 'a non_empty_set
   end

La 2ième chose c'est que l'on veut 2 modules-valeurs de ce module-type .

On veut un module-argument pour les ensembles totalement ordonnés   immutables .

Spoiler (Sélectionnez le texte dans le cadre pointillé pour le faire apparaître)

(* Immutable totally ordered Sets *)
module PureOrderedSet : OrderedSet =
   struct
      type 'a set =
         'a non_empty_set option
      and 'a non_empty_set =
         {mutable left: 'a set; item: 'a; mutable right: 'a set}
      let empty = None
      let make l x r = {left=l; item=x; right=r}
      let with_left  s l = {s with left=l}
      let with_right s r = {s with right=r}
   end

On veut un module-argument pour les ensembles totalement ordonnés   mutables .

Spoiler (Sélectionnez le texte dans le cadre pointillé pour le faire apparaître)

(* Mutable totally ordered Sets *)
module MutableOrderedSet : OrderedSet =
   struct
      type 'a set =
         'a non_empty_set option
      and 'a non_empty_set =
         {mutable left: 'a set; item: 'a; mutable right: 'a set}
      let empty = None
      let make l x r = {left=l; item=x; right=r}
      let with_left  s l = s.left  <- l; s
      let with_right s r = s.right <- r; s
   end

La 3ième chose c'est que la récursion c'est compliqué. On peut se tromper et si on se trompe il faudra déboguer, soit parce que le calcul ne termine pas ou bien parce que la valeur retournée est incorrecte.

Déboguer c'est du temps perdu pour rien .

Alors on va régler le problème une fois pour toutes en encapsulant la récursion sur les ensembles totalement ordonnés .

Spoiler (Sélectionnez le texte dans le cadre pointillé pour le faire apparaître)

(* Recursing upon totally ordered Sets *)
module OrderedSetRecursors(S:OrderedSet) =
   struct
      include S
      (* strict catamorphism *)
      type ('a,'b) fold =
         <empty: 'a; node: 'a -> 'b -> 'a -> 'a>
      let rec fold s (case:('a,'b) fold) =
         match s with
         | None -> case#empty
         | Some n -> case#node (fold n.left case) n.item (fold n.right case)
      (* lazy catamorphism *)
      type ('a,'b) cata =
         <empty: 'a; node: (unit -> 'a) -> 'b -> (unit -> 'a) -> 'a>
      let rec cata s (case:('a,'b) cata) () =
         match s with
         | None -> case#empty
         | Some n -> case#node (cata n.left case) n.item (cata n.right case)
      (* strict paramorphism *)
      type ('a,'b) recu =
         <empty: 'b;
          node: 'a non_empty_set -> 'b -> 'b -> 'b>
      let rec recu s (case:('a,'b) recu) =
         match s with
         | None ->
               case#empty
         | Some n ->
               case#node n (recu n.left case) (recu n.right case)
      (* lazy paramorphism *)
      type ('a,'b) para =
         <empty: 'b;
          node: 'a non_empty_set -> (unit -> 'b) -> (unit -> 'b) -> 'b>
      let rec para s (case:('a,'b) para) () =
         match s with
         | None ->
               case#empty
         | Some n ->
               case#node n (para n.left case) (para n.right case)
      let para_non_empty n (case:('a,'b) para) () =
         case#node n (para n.left case) (para n.right case)
   end

On veut une dernière chose :

Pouvoir créer des ensembles totalement ordonnés mutables ou immutables

Les équiper de toutes les opérations ensemblistes, à savoir e ∈ S, A ∪ B, A ∩ B, A ⊃ B, A - B, A = B, ∀ e ∈ S on a P(e), {e ∈ S, P(e)}

Que toutes ces opérations soient performantes, qu'elles utilisent le fait que les ensembles sont ordonnées. Par exemple il est hors de question d'ajouter les éléments de A un-par-un à l'ensemble B pour calculer A ∪ B. 

Spoiler (Sélectionnez le texte dans le cadre pointillé pour le faire apparaître)

(* Build a concrete totally ordered Set *)
module MakeSet(S:OrderedSet)
   =
   struct
      (* general *)
      include
         OrderedSetRecursors(S)
      let cardinal s =
         fold s (
            object
               method empty = 0
               method node l _ r = l + 1 + r
            end )
      let for_all cond s =
         cata s (
            object
               method empty = true
               method node l y r =
                  l() && cond y && r()
            end ) ()
      (* binary tree set *)
      let member x s =
         cata s (
            object
               method empty = false
               method node l y r =
                  if x < y then l()
                  else if x > y then r()
                  else true
            end ) ()
      let insert x s =
         para s (
            object
               method empty =
                  make None x None
               method node n l r =
                  let y = n.item in
                  if x < y then with_left n (Some (l()))
                  else if x > y then with_left n (Some (r()))
                  else n
            end ) ()
      let minimum s =
         para_non_empty s (
            object
               method empty = s
               method node n l r =
                  if n.left = empty then n
                  else l()
            end ) ()
      let remove_minimum s =
         para_non_empty s (
            object
               method empty = empty
               method node n l r =
                  if n.left = empty then n.right
                  else Some (with_left n (l()))
            end ) ()
      (* concatenation of sa + sb where max(sa) < min(sb) *)            
      let concat sa sb =
         if sa = empty then sb else
         match sb with
         | None -> sa
         | Some n ->
            let m = minimum n
            and r = remove_minimum n
            in Some (with_right (with_left m sa) r)
      let remove x s =
         para s (
            object
               method empty =
                  empty
               method node n l r =
                  let y = n.item in
                  if x < y then Some (with_left n (l()))
                  else if x > y then Some (with_right n (r()))
                  else concat n.left n.right
            end ) ()
      let split x s =
         para s (
            object
               method empty =
                  empty,false,empty
               method node n l r =
                  let y = n.item in
                  if x < y then
                     let a,b,c = l() in
                     a,b,Some (with_left n c)
                  else if x > y then
                     let a,b,c = r() in
                     Some (with_right n a),b,c
                  else
                     n.left,true,n.right
            end ) ()
      let filter cond s =
         recu s (
            object
               method empty =
                  empty
               method node n l r =
                  if cond n.item then
                     Some (with_right (with_left n l) r)
                  else
                     concat l r
            end )
      let union sa sb =
         recu sa (
            object
               method empty s =
                  s
               method node m l r s =
                  Some (
                  match s with
                  | None -> m
                  | Some n ->
                     let a,b,c = split m.item s in
                     with_right (with_left m (l a)) (r c))
            end ) sb
      let intersection sa sb =
         recu sa (
            object
               method empty s =
                  empty
               method node m l r s =
                  match s with
                  | None -> empty
                  | Some n ->
                     let a,b,c = split m.item s in
                     if b then
                        Some (with_right (with_left m (l a)) (r c))
                     else
                        concat (l a) (r c)
            end ) sb
      (* sa - sb *)
      let difference sa sb =
         recu sa (
            object
               method empty s =
                  empty
               method node m l r s =
                  match s with
                  | None ->
                     Some m
                  | Some n ->
                     let a,b,c = split m.item s in
                     if b then
                        concat (l a) (r c)
                     else
                        Some (with_right (with_left m (l a)) (r c))
            end ) sb
      let subset sa sb =
         recu sa (
            object
               method empty s =
                  true
               method node m l r s =
                  match s with
                  | None -> false
                  | Some n ->
                     if m.item < n.item then
                        (l n.left) && member m.item n.left && (r s)
                     else if m.item > n.item then
                        (l s) && member m.item n.right && (r n.right)
                     else
                        (l n.left) && (r n.right)
            end ) sb
      let equal sa sb =
         subset sa sb && subset sb sa
   end

Désormais, pour créer un module ensemble totalement ordonné immutable :

module PSet = MakeSet(PureOrderedSet)

Désormais, pour créer un module ensemble totalement ordonné mutable :

module MSet = MakeSet(MutableOrderedSet)

Les fonctions ont toutes le type approprié. Par exemple il est impossible de retirer un élément d'un ensemble vide parce que la fonction remove est du type :

val remove : 'a -> 'a non_empty_set -> 'a set

Réciproquement, lorsque l'on insère un élément dans un ensemble quelconque, on obtient forcément un ensemble non vide   :

val insert : 'a -> 'a set -> 'a non_empty_set

Les derniers commentaires

Ertaï il y a plus de 11 ans

J'ai du mal à comprendre le fond de cet article, mais je constate que la coloration syntaxique marche bien, c'est déjà ça Smile

:: Utilisateurs Réfugiés SpiceGuid ► Jouons avec du (vrai) code OCaml