Publicité
+ Répondre à la discussion
Page 1 sur 8 12345 ... DernièreDernière
Affichage des résultats 1 à 20 sur 158
  1. #1
    Rédacteur/Modérateur

    Avatar de gorgonite
    Homme Profil pro Nicolas Vallée
    Ingénieur d'études
    Inscrit en
    décembre 2005
    Messages
    10 220
    Détails du profil
    Informations personnelles :
    Nom : Homme Nicolas Vallée
    Âge : 30
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur d'études
    Secteur : Transports

    Informations forums :
    Inscription : décembre 2005
    Messages : 10 220
    Points : 17 577
    Points
    17 577

    Par défaut Page code source, mettez vos sources ici !

    Vous avez des codes sources dans les langages fonctionnels ?
    Vous pensez que ces codes sources peuvent aider d'autres personnes ?
    Vous souhaitez partager vos codes avec des internautes ?

    Dans ce cas, participez à l'enrichissement des pages de codes sources de developpez.com et postez à la suite

    Pour chaque proposition, merci d'expliquer en quelques mots ce que fait le code, s'il nécessite des bibliothèques ou des options particulières.
    Evitez les MP pour les questions techniques... il y a des forums
    Contributions sur DVP : Mes Tutos | Mon Blog

  2. #2
    Membre éclairé Avatar de Strab
    Inscrit en
    mai 2004
    Messages
    338
    Détails du profil
    Informations personnelles :
    Âge : 30

    Informations forums :
    Inscription : mai 2004
    Messages : 338
    Points : 338
    Points
    338

    Par défaut Parcours de graphes

    Voici quelques fonctions de traitement des graphes que j'avais fait il y a quelques années pour un exercice scolaire. Cela offre une alternative intéressante je trouve à l'implémentation des graphes utilisée dans le tutoriel de millie (cf forum cours et tutoriels). Je ne sais pas si elle est meilleure ou quoi, je n'ai jamais cherché à savoir, je l'avais juste trouvée jolie à ce moment là

    Je donne tout le source tel quel. Il y a quelques fonctions inutiles, c'est sûrement parce qu'on avait pas le droit à grand chose dans le cadre de l'exercice. Chaque fonction est précédée d'un cartouche expliquant précisément ce qu'elle fait. C'est du Caml Light

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    type ’a graphe = { sommets : ’a list ; succ : ’a −> ’a list };;
    
    (* Interface appartient
    type : ’a −> ’a list −> bool
    arg : a = élément à rechercher
            l = liste de recherche
    post : true si a appartient à l, false sinon *)
    let rec appartient a l = match l with
       |[] −> false
       |t::q −> if a=t then true else appartient a q
    ;;
    
    
    (* Interface miroir
    type : ’a list −> ’a list
    arg : l = liste à inverser
    post : liste éléments de l dans l’odre inverse de celui de l *)
    let miroir l =
       let rec aux l acc = match l with
         |[] −> acc
         |t::q −> aux q (t::acc)
       in aux l []
    ;;
    
    
    (* Interface parcours
    type : ’a graphe −> ’a −> ’a list
    arg : graphe = graphe à parcourir
            x = sommet de départ
    pre : x est un sommet de graphe
    post : liste des sommets de g rencontrés lors de son parcours en profondeur à partir de son premier
     sommet. elle est dans l’odre où les sommets sont rencontrés *)
    let parcours graphe x =
       (* aux fait le travail de parcours en s’aidant de deux paramètres supplémentaires : *)
       (* les successeurs de x et les sommets déjà parcourus *)
       (* les sommets sont ajoutés dès leur rencontre : résultat à l’envers *)
       let rec aux graphe x succ_x result_temp = match succ_x with
         |[] −> result_temp
         |t::q −> if appartient t result_temp (* t a−t−il été déjà visité ? *)
           then    (* on passe à la suite *)
             aux graphe x q result_temp
           else    (* on parcours les successeurs de t avant de continuer avec ceux de x *)
             aux graphe x q (aux graphe t (graphe.succ t) (t::result_temp))
       in miroir (aux graphe x (graphe.succ x) [x])
    ;;
    
    
    (* Interface recherche
    type : ’a graphe −> ’a −> ’a −> ’a list −> ’a list −> ’a list −> bool * ’a list * ’a list
    arg : graphe
            a = sommet où commence la recherche
            b = sommet recherché
            succ_a = successeurs de a
            visites = sommets déjà visités au moment de cet appel
            temp = miroir du chemin parcouru pour rechercher arrivee
    pre : a et les éléments de succ_a sont des sommets de graphe
    post : triplet contenant :
             * un booléen vrai si il existe un chemin de graphe entre a et b
             * le miroir de ce chemin si il existe, celui du dernier essayé sinon
             * la liste des sommets visités *)
    let rec recherche graphe a b succ_a temp visites = match succ_a with
         |[] −> false,temp,visites
         |t::q −> if t=b then true,t::temp,visites    (* on est arrivé *)
           else if appartient t visites (* sommes−nous déjà passés ici ? *)
           then      (* on passe à la suite *)
             recherche graphe a b q temp visites
           else      (* on essaye en passant par t... *)
             let trouve,temp’,visites’ = recherche graphe t b (graphe.succ t) (t::temp) (t::visites) in
             if trouve
             then trouve,temp’,visites’ (* ... et ça a marché *)
             else recherche graphe a b q temp visites’ (* ... en vain : on passe à la suite *)
    ;;
    
    
    (* Interface circuit
    type : ’a graphe −> ’a −> ’a list
    arg : graphe = graphe où est recherché le circuit
            x = sommet que doit contenir le circuit recherché
    pre : x est un sommet de graphe
    post : un circuit (donc orienté) de graphe passant par x si il existe, la liste vide sinon *)
    let circuit graphe x =
       let (trouve,chemin,_) = recherche graphe x x (graphe.succ x) [x] [x] in
         if trouve then miroir chemin else []
    ;;
    
    
    (* Interface pred
    type : ’a graphe −> ’a −> ’a list
    arg : graphe
            x = sommet dont on veut les prédécesseurs
            sommets susceptibles d’être des prédécesseurs de x
    pre : les éléments de sommets et x sont des sommets de graphe
    post : liste des prédécesseurs de x *)
    let rec pred graphe x sommets = match sommets with
       |[] −> []
       |t::q −> if t=x then pred graphe x q
                 else if appartient x (graphe.succ t) then t::(pred graphe x q)
                 else pred graphe x q
    ;;
    
    
    (* Interface desoriente
    type : ’a graphe −> ’a graphe
    arg : graphe
    post : renvoie graphe modifié de manière à ne plus tenir compte de l’orientation des arcs *)
    let desoriente graphe =
       (* aux calcule la fonction succ associée au graphe désorienté *)
       let rec aux graphe sommets = match sommets with
         |[] −> (function x −> failwith "sommet inconnu")
         |t::q −> function
             |x when (x=t) −> (graphe.succ t)@(pred graphe t graphe.sommets)
             |x −> (aux graphe q) x
       in let succ’ = aux graphe graphe.sommets
       in { sommets = graphe.sommets ; succ = succ’ }
    ;;
    
    
    type ’a precedent = Rien | P of ’a;;
    
    
    (* Interface cycle
    type : ’a graphe −> ’a −> ’a list
    arg : graphe = graphe où est recherché le cycle
            x = sommet que doit contenir le cycle recherché
    pre : x est un sommet de graphe
    post : un cycle de graphe passant par x si il existe, la liste vide sinon *)
    let cycle graphe x =
       let back t prec l = match prec with
         |Rien −> true
         |P(x) −> (t <> x) || appartient t l
       in let rec recherche2 graphe a b succ_a prec temp visites = match succ_a with
         |[] −> false,temp,visites
         |t::q −> if (t=b) && (back t prec q) (* On de doit pas revenir en arrière *)
           then true,t::temp,visites    (* on est arrivé *)
           else if appartient t visites (* sommes−nous déjà passés ici ? *)
           then      (* on passe à la suite *)
             recherche2 graphe a b q prec temp visites
           else      (* on essaye en passant par t... *)
             let trouve,temp’,visites’ = recherche2 graphe t b (graphe.succ t) (P a) (t::temp) (t::visites)
    in
             if trouve
             then trouve,temp’,visites’ (* ... et ça a marché *)
             else recherche2 graphe a b q prec temp visites’ (* ... en vain : on passe à la suite *)
       in let graphe’ = desoriente graphe in
       let (trouve,chemin,_) = recherche2 graphe’ x x (graphe’.succ x) Rien [x] [x] in
         if trouve then miroir chemin else []
    ;;
    
    
    (* Interface chemin
    type : ’a graphe −> ’a −> ’a −> ’a list
    arg : graphe = graphe où le chemin est recherché
            a = extremité initiale du chemin recherché
            b = extrémité finale du chemin recherché
    pre : a est un sommet de graphe
    post : un chemin de graphe entre a et b si il existe, la liste vide sinon *)
    let chemin graphe a b =
       let (trouve,reponse,_) = recherche graphe a b (graphe.succ a) [a] [a] in
         if trouve then miroir reponse else []
    ;;
    
    
    type ’a graphevalue = { sommets : ’a list ; succ : ’a −> (’a * int) list };;
    
    
    (* Interface retire
    type : ’a −> ’a list −> ’a list
    arg : a = élément à retirer
            l = liste à modifier
    post : l privée de la première occurence de a si elle existe (l sinon) *)
    let rec retire a l = match l with
       | [] −> []
       |t::q−> if a=t then q else t::(retire a q)
    ;;
    
    
    (* Interface inf
    type : int −> int −> bool
    arg : a b
    post : true si a < b, false sinon, en considérant que −1 = l’infini *)
    let inf a b = (a <> −1) && ( (b = −1) || (a < b) );;
    
    
    (* Interface distmin
    type : ’a list −> (’a * int) list −> ’a * int
    arg : sbar = liste de sommets
            distances = liste de couples (sommet, distance)
    pre : sbar et distances sont non vides
    post : plus petit couple de distances (en ordonnant les couples par rapport à leur second élément) dont
     le premier élément appartient à sbar
    raises : si sbar ou distances est vide *)
    let rec distmin sbar distances =
       (* aux garde le plus petit couple trouvé en paramètre *)
       let rec aux sbar distances mintmp = match distances with
         | [] −> mintmp
         |(i,pi_i)::q −> let (j,pi_j) = mintmp in
              if (inf pi_i pi_j) && (appartient i sbar)
              then aux sbar q (i,pi_i) (* on a trouvé plus petit : on garde *)
              else aux sbar q mintmp
       in match distances with (* on cherche un premier mintmp avant d’appeler aux *)
         | [] −> failwith "distmin : l’un des arguments est vide"
         |(i,pi_i)::q −> if appartient i sbar
           then aux sbar q (i,pi_i)
           else distmin sbar q
    ;;
    
    
    (* Interface longueur_arc
    type : (’a * int) list −> ’a −> ’a −> int
    arg : succ_i = successeurs de i
            i = extrêmité initiale de l’arc recherché
            j = son extrêmité finale
    post : valeur de l’arc (i,j) si il existe, −1 sinon (représente l’infini) *)
    let rec longueur_arc succ_i i j = if i=j then 0 else
       match succ_i with
         | []       −> −1
         |(t,d)::q −> if j=t then d else longueur_arc q i j
    ;;
    
    
    (* Interface min2
    type : int −> int −> int
    arg : a b
    pre : a est positif ou infini (égal à −1), b est positif
    post : retourne le minimum des deux entiers en tenant compte de la possible infinitude de a *)
    let min2 a b =
       if a < 0 then b else min a b
    ;;
    
    
    (* Interface update
    type : ’a graphevalue −> ’a list −> ’a −> int −> (’a * int) list −> (’a * int) list
    arg : graphe
            sbar = liste de sommets
            j = sommet dont on veut mettre à jour les successeurs
            pi_j = distance de x0 à j (valeur définitive)
            distances = liste des couples (sommet, distance de sommet à x0)
    pre : j est un sommet de graphe, pi_j non infini (différent de −1), distances contient les couples de
    tous les sommets de graphe
    post : pour chaque sommet i de sbar successeur de j, met à jour le couple correspondant si le chemin
     passant par j est plus court que l’actuel, ne modifie rien pour les autres *)
    let rec update graphe sbar j pi_j distances = match distances with
       |[] −> []
       |(i,pi_i)::q −> let lji = longueur_arc (graphe.succ j) j i in
          if (lji > 0) && (appartient i sbar)             (* successeur de j dans sbar ? *)
          then (i,min2 pi_i (pi_j + lji))::(update graphe sbar j pi_j q)
          else (i,pi_i)::(update graphe sbar j pi_j q)    (* on ne modifie pas à i *)
    ;;
    
    
    (* Interface init_dist
    type : ’a −> ’a list −> (’a * int) list −> (’a * int) list
    arg : x = sommet initial des chemins calculés
            sommets (du graphe)
            succ_x = successeurs de x
    post : liste des couples (s, valeur de l’arc (x0,s)), cette valeur étant infinie si l’arc n’existe pas *)
    let rec init_dist x sommets succ_x = match sommets with
       | [] −> []
       |t::q −> (t, longueur_arc succ_x x t)::(init_dist x q succ_x)
    ;;
    
    
    (* Interface pluscourtschemins
    type : ’a graphevalue −> ’a −> (’a * int) list
    arg : graphe (valué)
            x = sommet de départ
    pre : x est un sommet de graphe
    post : liste des couples (s,l) où l est la plus petite des longueurs des chemins de x au sommet s.
            Utilise l’algorithme de Dijkstra *)
    let pluscourtschemins graphe x =
       let rec aux graphe sbar distances =     (* on n’a pas besoin de x pour continuer *)
         let (j,pi_j) = distmin sbar distances in
           if (pi_j < 0) then distances (* si l’infini est la valeur minimum, on a fini *)
           else
             let sbar’ = retire j sbar in match sbar’ with
                | [] −> distances
                | _ −> aux graphe sbar’ (update graphe sbar’ j pi_j distances)
       in aux graphe (retire x (graphe.sommets)) (init_dist x graphe.sommets (graphe.succ x))
    ;;

  3. #3
    Membre à l'essai
    Profil pro
    Étudiant
    Inscrit en
    mai 2007
    Messages
    47
    Détails du profil
    Informations personnelles :
    Âge : 26
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Étudiant

    Informations forums :
    Inscription : mai 2007
    Messages : 47
    Points : 21
    Points
    21

    Par défaut Produit de convolution

    Bonjour à tous,
    Voici mon premier code en Camllight concernant le traitement d'images numériques. Ce programme calcul le produit de convolution d'une matrice u (image) et d'une matrice h (noyau) la matrice u étant de taille quelconque et la matrice h étant de taille impaire x impaire
    Il ne nécéssite ni bibliothèque ni options particulieres.

    Il se décompose en trois sous fonctions.

    la premiere est la suivante; elle permet de calculer u*h (produit de convolution) au point (x y)

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    let convol_simpl_imp_imp h u x y = 
      let m = vect_length h and n = vect_length h.(0) in
        let a= ref 0 in     
          for i = -((m-1)/2) to ((m-1)/2) do
            for j = -((n-1)/2) to ((n-1)/2) do
              a := (  !a+  (  (  h.(i + ((m-1)/2)).(j + ((n-1)/2))   )*(u.(x+i).(y+j)) ) )
              done;
                done; 
    (!a)
    ;;
    on récupère la taille de h :
    Code :
    let m = vect_length h and n = vect_length h.(0) in
    puis on applique la formule de convolution sur un espace discret (dans le cas simple ou la fonction représenté par u est à support borné.)
    Code :
    1
    2
    3
          for i = -((m-1)/2) to ((m-1)/2) do
            for j = -((n-1)/2) to ((n-1)/2) do
              a := (  !a+  (  (  h.(i + ((m-1)/2)).(j + ((n-1)/2))   )*(u.(x+i).(y+j)) ) )


    On doit désormait appliquer cette fonction en chaque point de la matrice u; ainsi pour ne pas "déborder" on doit "grossir" la matrice u avant de lui appliquer h.
    C'est à cela que sert la fonction suivante:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    let grossir_imp_imp u h  =
    
    let k = vect_length u and l = vect_length u.(0) in 
    let m = vect_length h and n = vect_length h.(0) in 
      let u_sec = make_vect (k+m-1) [|0;0|] in
        for i = 0 to (k+ m -2) do
          u_sec.(i)<-( make_vect (l+n-1) 0) done; 
    
    for i = (m/2) to ((m/2)+k-1) do
      for j = (n/2) to ((n/2)+l-1) do 
        u_sec.(i).(j)<-(u.(i-(m/2)).(j-(n/2)))
      done; 
    done;
    u_sec ;;
    la méthode est la suivante: on récupère la taille de u et celle de h :
    Code :
    1
    2
    let k = vect_length u and l = vect_length u.(0) in 
    let m = vect_length h and n = vect_length h.(0) in
    On crée la matrice de taille suffisante pour que h s'applique en tout points de u :
    Code :
    1
    2
    3
      let u_sec = make_vect (k+m-1) [|0;0|] in
        for i = 0 to (k+ m -2) do
          u_sec.(i)<-( make_vect (l+n-1) 0) done;
    à se stade u_sec est une matrice pleine de 0 de la taille souhaitée. on place u en son centre.
    Code :
    1
    2
    3
    4
    5
    for i = (m/2) to ((m/2)+k-1) do
      for j = (n/2) to ((n/2)+l-1) do 
        u_sec.(i).(j)<-(u.(i-(m/2)).(j-(n/2)))
      done; 
    done;
    On peut désormais appliquer h en tout points de u :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    let convol_imp_imp h u = 
      let k = vect_length u and l = vect_length u.(0) in 
      let m = vect_length h and n = vect_length h.(0) in 
    
    let u_sec = make_vect (k+m-1) [|0;0|] in
        for i = 0 to (k+ m -2) do
          u_sec.(i)<-( make_vect (l+n-1) 0) done; 
    
      let u_tres = ( grossir_imp_imp u h ) in
        
    for i = (m/2) to ((m/2)+k-1) do
      for j = (n/2) to ((n/2)+l-1) do 
            u_sec.(i).(j)<-(convol_simpl_imp_imp h  u_tres i j ) 
          done;
        done;
    u_sec ;;

    à ce stade :
    pour u = [|[|1;1;1|];[|2;2;2|]|] et h = [|[|0;-1;1|]|]
    losrqu'on exécute grossir_imp_imp u h on obtient [|[|0; 1; 1; 1; 0|]; [|0; 2; 2; 2; 0|]|]
    lorsqu'on exécute convol_imp_imp h u on obtient [|[|0; 0; 0; -1; 0|]; [|0; 0; 0; -2; 0|]|]

    On peut cependant faire la même fonction qui rend le même résultat sans ajouter les zeros sur les contours:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    let convol_nodark_imp_imp h u = 
     let k = vect_length u and l = vect_length u.(0) in 
      let m = vect_length h and n = vect_length h.(0) in
    
        let u_sec = make_vect k [|0;0|] in
          for i = 0 to (k-1) do
            u_sec.(i)<-(make_vect (l) 0) done;
    
        let u_tres = convol_imp_imp h u in 
    
          for i = (m/2) to ((m/2)+k-1) do
          for j = (n/2) to ((n/2)+l-1) do 
            u_sec.(i-(m/2)).(j-(n/2))<-u_tres.(i).(j) 
          done;
          done; 
    u_sec ;;
    il suffit en effet de recopier le résultat "utile" (ie le centre) de "convol_imp_imp h u " dans une matrice de la taille de u ... (il faut seulement décaler les indices dans le for.)


    Voilà peut-être que ça servira à quelqu'un un jour ^^
    Rémy.

  4. #4
    Membre Expert
    Avatar de InOCamlWeTrust
    Inscrit en
    septembre 2006
    Messages
    1 036
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 1 036
    Points : 1 265
    Points
    1 265

    Par défaut

    Indente le code s'il te plaît et pense à la balise .

  5. #5
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Mes codes sources sont tous en Objective Caml 3.08 ou plus.

    Je commence par quelques fonctions utilitaires pour les listes:


    make génère une liste de n éléments à partir de l'élément a et en appliquant n-1 fois la fonction u:

    Code :
    1
    2
    3
    let rec make u a n =
      if n=1 then a
      else let b=make u a (n-1) in u n b::b;;
    exemple, générer les 10 premiers entiers:

    Code :
    make (fun _ l -> List.hd l + 1) [0] 10;;
    autre exemple qui génére les 10 premiers nombres de fibonacci:

    Code :
    make (fun _ l -> List.nth l 0 + List.nth l 1) [1;0] 10;;
    un dernier exemple qui génére les 10 premiers factoriels:

    Code :
    make (fun n l -> n * List.hd l) [1;0] 10;;

    La fonction pair_list génère toutes les paires possibles formées à partir d'une liste l:

    Code :
    1
    2
    3
    4
    let rec pair_list l =
      match l with
      | []  -> []
      | a::l -> (List.map (fun b -> a,b) l) @ pair_list l;;

    Enfin la fonction exists_commutative teste l'existence de deux éléments de la liste l qui vérifient le prédicat 2-aire commutatif cond:

    Code :
    1
    2
    3
    4
    5
    6
    let exists_commutative cond l =
      let rec loop l = 
        match l with
        | []   -> false
        | a::l -> (List.exists (cond a) l) or loop l   
      in loop l;;

  6. #6
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Je continue avec un algorithme rapide de calcul de PI en goutte-à-goutte, toujours en Objective-Caml.

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    let add  = Big_int.add_big_int
    and sub  = Big_int.sub_big_int
    and succ = Big_int.succ_big_int
    and pred = Big_int.pred_big_int
    and mult = Big_int.mult_big_int
    and div  = Big_int.div_big_int
    and add_int  = Big_int.add_int_big_int
    and mult_int = Big_int.mult_int_big_int
    and big_int  = Big_int.big_int_of_int
    and int_of   = Big_int.int_of_big_int
    ;;
    
    let pi () =
      let rec g q r t i =
        let i3 = mult_int 3 i in
        let u = mult_int 3 (mult (succ i3) (add_int 2 i3))
        and y = int_of (div (add (mult q (add_int (-12) (mult_int 27 i))) (mult_int 5 r)) (mult_int 5 t)) 
        in begin
          print_int y;
          flush stdout;
          g
          (mult_int 10 (mult q (mult i (pred (add i i)))))
          (mult_int 10 (mult u (sub (add (mult q (add_int (-2) (mult_int 5 i))) r) (mult_int y t))))
          (mult t u)
          (succ i);
          ()
        end
      in g (big_int 1) (big_int 180) (big_int 60) (big_int 2);; 
    
    pi ();;
    À compiler avec:

    Code :
    ocamlopt -unsafe -o pi.exe nums.cmxa pi.ml
    Sinon dans l'interpréteur il vous faudra d'abord entrer cette commande:
    Les plus connaisseurs pourront encore accélérer l'algorithme à l'aide de la bibliothèque numerix de Michel Quercia.

  7. #7
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Et mainenant des routines pour les inventaires.

    Le type inventaire:
    Code :
    1
    2
    type 'a inventory = ('a * int) list;;
    type 'a t = 'a inventory;;
    Un inventaire est une liste énumérative qui dit par exemple "j'ai 3 livres et deux tasses à café".

    Code :
    ([("livre",3);("tasse",2)] : string inventory);;
    Le test de validité d'un inventaire, en particulier un inventaire ne peut pas contenir un négatif ou nul, un inventaire valide est également trié par ordre croissant:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    let valid (a: 'a inventory) =
      let rec helper prev l =
        match l with
        | [] -> true
        | (p,n)::t -> if (n > 0) && (p > prev) then helper p t else false
      in match a with
      | [] -> true
      | (p,n)::t ->  if n > 0 then helper p t else false;;
    Le constructeur d'inventaire à partir d'un liste l:
    Code :
    1
    2
    3
    4
    let make l =
      let sorted = List.sort (fun (p1,_) (p2,_) -> compare p1 p2) l in
      if valid sorted then (sorted : 'a inventory)
      else failwith "Inventory.make";;
    La liste retounée est garantie valide.

    Maintenant les opérations élémentaires.

    L'union et l'intersection de deux inventaires:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    let union (a: 'a inventory) (b: 'a inventory) =
      let rec helper a b u =
        match a,b with
        | [],_ -> List.rev_append u b
        | _,[] -> List.rev_append u a
        | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
            if pa < pb then helper ta b (ha::u)
            else if pa > pb then helper a tb (hb::u)
            else helper ta tb ((pa,qa+qb)::u)
      in (helper a b []: 'a inventory);;
    
    let intersection (a: 'a inventory) (b: 'a inventory) =
      let rec helper a b c =
        match a,b with
        | [],_ -> List.rev c
        | _,[] -> List.rev c
        | (pa,qa)::ta,(pb,qb)::tb ->
            if pa < pb then helper ta b c
            else if pa > pb then helper a tb c
            else helper ta tb ((pa,min qa qb)::c)
      in (helper a b []: 'a inventory);;
    La différence de deux inventaires, qui renvoie à la fois a-b et b-a, et la soustraction qui elle renvoie seulement a-b:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    let difference (a: 'a inventory) (b: 'a inventory) =
      let rec helper a b r x =
        match a,b with
        | [],_ -> List.rev r,List.rev_append x b
        | _,[] -> List.rev_append r a,List.rev x
        | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
            if pa < pb then
              helper ta b (ha::r) x
            else if pa > pb then
              helper a tb r (hb::x)
            else if qa < qb then
              helper ta tb r ((pa,qb-qa)::x)
            else if qa > qb then
              helper ta tb ((pa,qa-qb)::r) x
            else
              helper ta tb r x
      in (helper a b [] []: 'a inventory * 'a inventory);;
    
    let minus (a: 'a inventory) (b: 'a inventory) =
      let rec helper a b r =
        match a,b with
        | [],_ -> List.rev r
        | _,[] -> List.rev_append r a
        | (pa,qa as ha)::ta,(pb,qb as hb)::tb ->
            if pa < pb then
              helper ta b (ha::r)
            else if pa > pb then
              helper a tb r
            else if qa < qb then
              helper ta tb r
            else if qa > qb then
              helper ta tb ((pa,qa-qb)::r)
            else
              helper ta tb r
      in (helper a b []: 'a inventory);;
    Le test d'inclusion et le test d'intersection pour deux inventaires:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    let rec includes (a: 'a inventory) (b: 'a inventory) =
      match a,b with
      | [],_ -> b=[]
      | _,[] -> true
      | (pa,qa)::ta,(pb,qb)::tb ->
          if pa < pb then
            includes ta b
          else if pa > pb then
            false
          else if qa >= qb then
            includes ta tb
          else
            false;;
    
    let rec intersects (a: 'a inventory) (b: 'a inventory) =
      match a,b with
      | [],_ -> false
      | _,[] -> false
      | (pa,qa)::ta,(pb,qb)::tb ->
          if pa < pb then
            intersects ta b
          else if pa > pb then
            intersects a tb
          else
            true;;

  8. #8
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    La suite des fonctions sur les inventaires.
    Ces fonctions paraissent beaucoup moins naturelles car ce sont des utilitaires pour la "grosse" fonction collect tout à la fin.

    Multiplier un inventaire par un entier n:
    Code :
    1
    2
    3
    let scale n (a: 'a inventory) =
      assert(n > 0);
      (List.map (fun (p,q) -> (p,n*q)) a : 'a inventory);;
    Diviser un inventaire par un autre inventaire, renvoie le nombre n de fois que a inclut b ainsi que l'inventaire restant après avoir retranché n x b:
    Code :
    1
    2
    3
    4
    5
    6
    7
    let reduce (a: 'a inventory) (b: 'a inventory) =
      let rec helper n a =
        if includes a b then
          helper (n+1) (minus a b)
        else
          n,a
      in helper 0 a;;
    Le nombre total d'articles dans un inventaire:
    Code :
    1
    2
    3
    4
    5
    6
    let length (a: 'a inventory) =
      let rec helper a n =
        match a with
        | [] -> n
        | (_,q)::t -> helper t (n+q)
      in helper a 0;;
    Une fonction qui évalue l'écart entre deux inventaires:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    let distance (a: 'a inventory) (b: 'a inventory) =
      let rec helper a b c x =
        match a,b with
        | _,[] -> c,x
        | [],_ -> c,x + length b
        | (pa,qa)::ta,(pb,qb)::tb ->
            if pa < pb then
              helper ta b c x
            else if pa > pb then
              helper a tb c (x+qb)
            else if qa <= qb then
              helper ta tb (c+qa) (x+qb-qa)
            else
              helper ta tb (c+qb) (x+qa-qb)
        in helper a b 0 0;;
    Une fonction qui dit lequel de a ou de b est plus proche de l'inventaire wanted:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    let discriminate (wanted: 'a inventory) a b =
      let ca,xa = distance wanted a in
      let cb,xb = distance wanted b in
      let cb_xa = cb * xa in
      let ca_xb = ca * xb in
      if cb_xa < ca_xb then 1
      else if cb_xa > ca_xb then -1
      else 0;;
    Deux types supplémentaires, un catalog est une liste d'inventaires, un order est le bon de commande d'un inventaire:
    Code :
    1
    2
    type ('a,'b) catalog = ('a * 'b inventory) list;;
    type ('a,'b) order = {items: 'a inventory; missing: 'b inventory; extras: 'b inventory};;
    Comme un inventaire, un catalog a son test de validité:
    Code :
    1
    2
    let valid_catalog (cat: ('a,'b) catalog) =
      List.for_all (fun (_,inv) -> valid inv) cat;;
    La fonction supercede n'est qu'un utilitaire pour la fonction collect qui suit
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    let rec supercede k_max inv_max (wanted: 'b inventory) (cat: ('a,'b) catalog) =
      match cat with
      | [] -> k_max,inv_max
      | (k,inv)::l ->
        if discriminate wanted inv inv_max > 0 then
          supercede k inv wanted l
        else
          supercede k_max inv_max wanted l;;
    La voilà cette fonction collect, elle vise à s'approcher de l'inventaire wanted à l'aide du catalog cat, c'est-à-dire qu'elle renvoie l'order le mieux susceptible de satisfaire l'inventaire wanted voulu:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    let collect (wanted: 'b inventory) (cat: ('a,'b) catalog) margin =
      assert(valid_catalog cat);
      assert(valid wanted);
      assert(0 <= margin && margin < length wanted);
      let rec helper wanted cat keys extras =
        if length wanted <= margin then
          {items=keys;missing=wanted;extras=extras}
        else
        let passed =
          List.filter (fun (_,inv) -> intersects wanted inv) cat
        in match passed with
           | [] -> failwith "Inventory.collect"
           | (k,inv)::l ->
             let k_max,inv_max = supercede k inv wanted l in
             let rest,more = difference wanted inv_max in
             helper rest passed (union keys [k_max,1]) (union more extras)
      in helper wanted cat [] [];;
    Exemple pratique: à l'aide d'une base de données fonctionnelle (le catalog de toutes les boîtes lego référencées) la fonction collect renvoie les 8 à 10 boîtes lego qui typiquement fourniraient 70% à 80% des éléments nécessaires pour construire un modèle original de 1000 briques.

  9. #9
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Voici quelques fonctions de manipulation de motifs.

    Le type motif et son afficheur:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    type pattern_val =
       | Pattern of string * pattern_val list
       | Var of string
       | Int of int
    ;;
    
    let rec print_pattern pat =
      match pat with
      | Pattern(op,sons) ->
          if sons=[] then
            print_string op
          else begin
            print_string op; print_char '(';
            print_pattern (List.hd sons);
            List.iter (fun x -> print_string ", "; print_pattern x) (List.tl sons);
            print_char ')'
          end
      | Var s -> print_string s
      | Int n -> print_int n
    ;;

    La fonction construct réalise l'instanciation de motif, les variables du motif pat sont remplacées par leur valeur associée dans l'environnement env:

    Code :
    1
    2
    3
    4
    5
    6
    7
    let rec construct env pat =
      let rec loop pat = 
      match pat with
      | Pattern(name,sons) -> Pattern(name, List.map loop sons)
      | Var s -> (try List.assoc s env with Not_found -> Var s)
      | _ -> pat
      in loop pat;;
    La fonction extend augmente l'environnement env par l'association de la variable var à la valeur pat:

    Code :
    1
    2
    3
    4
    5
    6
    7
    let extend env (var,pat) =
      try
        let pat1=List.assoc var env in
        if pat=pat1 then env else failwith "extend" 
      with
      | Not_found -> (var,pat)::env
    ;;
    La fonction occurs réalise le test d'occurrence de la variable var dans le motif pat:

    Code :
    1
    2
    3
    4
    5
    6
    7
    let occurs var pat =
      let rec loop pat =
      match pat with
      | Pattern(_,sons) -> List.exists loop sons
      | Var s -> s = var
      | _ -> false
      in loop pat;;
    La fonction unify réalise l'unification de deux motifs pat1 et pat2:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    let compose env2 env1 =
      (List.map (fun (var,pat) -> (var,construct env2 pat)) env1) @ env2
    ;;
    
    let rec unify pat1 pat2 =
      match pat1,pat2 with
      | pat1, pat2 when pat1 = pat2 -> []
      | Var s,v2   ->  if occurs s v2 then failwith "unify"
                       else [s,v2]
      | v1,Var s   ->  if occurs s v1 then failwith "unify"
                       else [s,v1]
      | Pattern(op1,sons1),Pattern(op2,sons2) ->
          if op1 = op2 then
            try
              let compose_unify env t1 t2 =
                  compose (unify (construct env t1) (construct env t2)) env
              in List.fold_left2 compose_unify [] sons1 sons2
            with
            | Invalid_argument "fold_left2" -> failwith "unify"
          else failwith "unify"
      | pat1, pat2 -> failwith "unify"
    ;;
    La fonction exists_commutative a déjà été décrite plus haut, elle teste l'existence de deux éléments de la liste l qui vérifient le prédicat 2-aire commutatif cond:
    Code :
    1
    2
    3
    4
    5
    6
    let exists_commutative cond l =
      let rec loop l = 
        match l with
        | []   -> false
        | a::l -> (List.exists (cond a) l) or loop l   
      in loop l;;
    Un filtrage est une liste de motifs.
    La fonction is_determinist réalise un test de déterminisme sur un filtrage, un filtrage est dit déterministe si aucuns de ses motifs ne sont unifiables deux-à-deux, dans un filtrage déterministe il n'y a toujours que zéro (le filtrage n'est pas forcément complet) ou un seul choix possible, jamais plusieurs:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    let can_unify (pat1,_) (pat2,_) =
      try
        let _ = unify pat1 pat2 in true
      with
      | Failure "unify" -> false;;
    
    let is_determinist pattern_list =
      not (exists_commutative can_unify pattern_list);;

  10. #10
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Ma bibliothèque ocaml pour l'arithmétique des grands nombres.
    L'implémentation utilise des tableaux d'entiers et supporte la base 10000 en 32 bits.
    J'ai massivement utilisé les assertions pour débugger plus vite.

    Le type big_int et son constructeur big_of_int:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    type big_int = int array;;
    
    let base = 10;;
    
    let zero_big = ([|0|]: big_int);;
    
    let unit_big = ([|1|]: big_int);;
    
    let big_of_int n =
      assert (0 <= n & n < base * base);
      if n < base then ([|n|]: big_int)
      else ([|n / base;n mod base|]: big_int);;

    La function add_big réalise l'addition destructive des grands entiers a et b (a est écrasé):

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    let add_big (a: big_int) (b: big_int) =
      assert (Array.length a >= Array.length b);
      let result = ref a
      and carry  = ref 0
      and i = ref (Array.length a - 1)
      and j = ref (Array.length b - 1)
      in begin
        while !j >= 0 do
          let d = a.(!i) + b.(!j) + !carry
          in if d < base then begin
            carry := 0; a.(!i) <- d 
          end else begin
            carry := 1; a.(!i) <- d - base
          end;
          decr i; decr j; 
        done;
        while !carry > 0 do
          if !i >= 0 then begin
            let d = a.(!i) + !carry
            in if d < base then begin
              carry := 0; a.(!i) <- d 
            end else begin
              a.(!i) <- d - base
            end;
            decr i;
          end else begin
            result := Array.make (Array.length a + 1) 0;
            Array.blit a 0 !result 1 (Array.length a);
            !result.(0) <- 1; carry := 0;
          end;
        done;
        !result
      end;;
    La function sum_big réalise l'addition non destructive des grands entiers a et b:

    Code :
    1
    2
    3
    4
    5
    let sum_big (a: big_int) (b: big_int) =
      if Array.length a >= Array.length b then
        add_big (Array.copy a) b
      else 
        add_big (Array.copy b) a;;
    La function compare_big compare deux grands entiers a et b:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    let compare_big (a: big_int) (b: big_int) =
      if Array.length a < Array.length b then -1
      else if Array.length a > Array.length b then 1
      else
        let i = ref 0 in
        begin
          while !i < Array.length a & a.(!i) = b.(!i) do
            incr i;
          done;
          if !i = Array.length a then 0
          else if a.(!i) > b.(!i) then 1
          else -1
        end;;
    Les functions min_big et max_big renvoient le minimum et le maximum de a et b:

    Code :
    1
    2
    3
    4
    5
    let min_big (a: big_int) (b: big_int) =
      if compare_big a b < 0 then a else b;;
    
    let max_big (a: big_int) (b: big_int) =
      if compare_big a b > 0 then a else b;;
    La function sub_big réalise la soustraction destructive des grands entiers a et b (a est écrasé):

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    let sub_big (a: big_int) (b: big_int) =
      assert (compare_big a b >= 0);
      let result = ref a
      and carry  = ref 0
      and i = ref (Array.length a - 1)
      and j = ref (Array.length b - 1)
      in begin
        while !j >= 0 do
          let d = a.(!i) - b.(!j) - !carry
          in if d >= 0 then begin
            carry := 0; a.(!i) <- d 
          end else begin
            carry := 1; a.(!i) <- d + base
          end;
          decr i; decr j; 
        done;
        while !carry > 0 do
          let d = a.(!i) - !carry
          in if d >= 0 then begin
            carry := 0; a.(!i) <- d 
          end else begin
            a.(!i) <- d + base
          end;
          decr i;
        done;
        if !i < 0 then begin
          i := 0; j := Array.length a - 1;
          while a.(!i) = 0 & !i < !j  do incr i; done;
          if !i >= 0 then result := Array.sub a !i (Array.length a - !i);
        end;  
        !result
      end;;
    La function sub_big réalise la soustraction non destructive des grands entiers a et b:

    Code :
    1
    2
    3
    let diff_big (a: big_int) (b: big_int) =
      assert (compare_big a b >= 0);
      sub_big (Array.copy a) b;;
    La function shift_big réalise un décalage à gauche:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    let shift_big (a: big_int) n =
      assert (n >= 0);
      if a = zero_big then zero_big
      else
        let result: big_int = Array.make (Array.length a + n) 0
        in begin
          Array.blit a 0 result 0 (Array.length a);
          result
        end;;
    La function scale_up_big réalise le produit par un nombre n < base :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    let scale_up_big (a: big_int) n =
      assert (0 <= n & n < base);
      if n = 0 then zero_big
      else 
        let accu = ref 0 
        and carry = ref 0
        and result: big_int = Array.make (Array.length a + 1) 0
        in begin
          for i = (Array.length a) downto 1 do
            accu := a.(i-1) * n + !carry; 
            result.(i) <- !accu mod base; carry := !accu/base
          done;
          result.(0) <- !carry;
          if !carry = 0 then
            (Array.sub result 1 (Array.length a): big_int)
          else
            result  
        end;;

    La multiplication ordinaire:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    let long_mult_big (a: big_int) (b: big_int) =
      let i = ref 0
      and j = ref (Array.length b-1) in
      let result = ref (shift_big (scale_up_big a b.(!i)) !j) 
      in begin
        while !j > 0 do
          incr i; decr j;
          result := add_big !result (shift_big (scale_up_big a b.(!i)) !j)
        done;  
        !result
      end;;
    La multiplication rapide à la Karatsuba:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    let array_sub (a: big_int) start len = 
      let i = ref start and n = ref len in
      while a.(!i)=0 && !n > 1 do
        incr i; decr n;
      done;
      (Array.sub a !i !n : big_int);;  
    
    let karatsuba_threshold = 20;;
    
    let rec mult_big (a: big_int) (b: big_int) =
      if Array.length a < Array.length b then
        mult_big b a
      else if Array.length b < karatsuba_threshold then
        long_mult_big a b
      else 
        karatsuba_big a b
    and karatsuba_big (p: big_int) (q: big_int) =
      assert (Array.length p >= Array.length q);
      let len_p = Array.length p  in
      let len_q = Array.length q  in
      let     n = len_p / 2       in
      let     a = array_sub p 0 (len_p - n)  in
      let     b = array_sub p (len_p - n) n  in
      if len_q > n then  
        let      c = array_sub q 0 (len_q - n)  in
        let      d = array_sub q (len_q - n) n  in
        let     ac = mult_big a c  in
        let     bd = mult_big b d  in
        let  ad_bc = sub_big (sub_big (mult_big (sum_big a b) (sum_big c d)) ac) bd
        in
        add_big (add_big (shift_big ac (2*n)) (shift_big ad_bc n)) bd
      else  
        let     aq = mult_big a q in
        let     bq = mult_big b q in
        add_big (shift_big aq n) bq
    ;;

    Le carré et la puissance:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    let square_big (a: big_int) = mult_big a a;; 
    
    let rec power_big (a: big_int) n =
      assert (n >= 0);
      if n=0 then unit_big
      else if n=1 then a
      else
        let b = power_big a (n/2) in
        if (n mod 2 = 0) then mult_big b b 
        else mult_big (mult_big b b) a
    ;;
    La function scale_down_big réalise la division par un nombre n < base² :

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    let scale_down_big (a: big_int) n =
      assert (0 < n & n < base * base);
      let accu = ref 0 
      and carry = ref 0
      and result: big_int = Array.copy a
      in begin
        for i = 0 to (Array.length a - 1) do
          accu := a.(i) + !carry * base; 
          result.(i) <- !accu/n; carry := !accu mod n
        done;
        if (result.(0) = 0) && (Array.length a > 1) then
          (Array.sub result 1 (Array.length a - 1): big_int),!carry
        else
          result,!carry  
      end;;
    La division rapide à la Burnikel-Ziegler:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    let rec burnikel_ziegler_big (a: big_int) (b: big_int) =
      if  Array.length b <= 2 then
        let b2 = if Array.length b < 2 then b.(0) else b.(0)*base + b.(1) in 
        let q,r = scale_down_big a b2
        in  q,big_of_int r
      else    
        let   len_a = Array.length a               in
        let   len_b = Array.length b               in
        let       n = (len_b - 1) / 2              in
        let      a0 = array_sub a (len_a - n) n    in
        let      a1 = array_sub a 0 (len_a - n)    in
        if compare_big a1 b >= 0 then
          let q1,r1 = burnikel_ziegler_big a1 b    in
          let q0,r0 = burnikel_ziegler_big (add_big (shift_big r1 n) a0) b
          in  add_big (shift_big q1 n) q0,r0
        else
          let    b0 = array_sub b (len_b - n) n    in
          let    b1 = array_sub b 0 (len_b - n)    in
          let q1,r1 = burnikel_ziegler_big a1 b1   in
          let a0_r1 = add_big (shift_big r1 n) a0  in
          let b0_q1 = mult_big b0 q1               in
          if compare_big a0_r1 b0_q1 >= 0 then
            let plus_x = sub_big a0_r1 b0_q1
            in  q1,plus_x
          else
            let minus_x = sub_big b0_q1 a0_r1 in
            sub_big q1 unit_big, sub_big b minus_x;;
    
    
    let quomod_big (a: big_int) (b: big_int) =
      if b = zero_big then raise Division_by_zero
      else if compare_big a b < 0 then zero_big,a
      else burnikel_ziegler_big a b;;

    Le nombre de permutations de p éléments parmi n:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    let rec permutation_big n p =
      assert(0 <= p & p <= n);
      let rec helper a b =
        if a = b then
          big_of_int a
        else if a + 1 = b then
          big_of_int (a * b)
        else 
          let ab2 = (a + b) / 2 in
          mult_big (helper a ab2) (helper (ab2+1) b)
      in if p = 0 then unit_big else helper (n - p + 1) n;;   
    
    let factorial_big n =
      assert(n >= 0);
      permutation_big n n;;

    Les coefficients du binôme:

    Code :
    1
    2
    3
    let binomial_big n p =
      assert(0 <= p & p <= n);
      div_big (permutation_big n p) (factorial_big p);;

  11. #11
    Rédacteur/Modérateur

    Avatar de millie
    Profil pro
    Inscrit en
    juin 2006
    Messages
    6 944
    Détails du profil
    Informations personnelles :
    Localisation : Luxembourg

    Informations forums :
    Inscription : juin 2006
    Messages : 6 944
    Points : 9 773
    Points
    9 773

    Par défaut

    En tout cas. Je te remercie pour toutes les sources que tu nous proposes
    Je ne répondrai à aucune question technique en privé

  12. #12
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Erratum:

    Je ne suis plus très certain de ma division rapide Burnikel-Ziegler, elle fait parfois planter l'interpréteur OCamlWin sans que je sache pourquoi, les fonctions qui l'utilisent peuvent donc également être affectées (quomod_big et binomial_big).

  13. #13
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Un petit dérivateur formel qui simplifie raisonnablement son résultat.

    Le type fonction d'une variable:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    type function_x = X
         | R of float
         | Sin of function_x
         | Cos of function_x
         | Tan of function_x
         | Log of function_x
         | Exp of function_x
         | Power of function_x * float
         | Add of function_x * function_x
         | Mul of function_x * function_x
    ;;
    Dans ce type vous remarquerez notamment l'absence de la soustraction et de la division, cela s'explique par le fait que:
    • la soustraction est redondante avec la multiplication par -1.
    • la division est redondante avec la puissance -1.


    Le fait d'éliminer ces redondances facilite grandement le travail de simplification d'écriture, il n'y a plus qu'à s'occuper de la factorisation (élémentaire), c'est ce que font les lignes suivantes:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    let multiply p = match p with
      | R(1.),u -> u
      | u,v -> Mul(u,v)
    ;;
      
    let product p = match p with
      | R(a),Mul(R(b),u) -> multiply(R(a*.b),u)
      | Mul(R(a),u),R(b) -> multiply(R(a*.b),u)
      | Mul(R(a),u),Mul(R(b),v) -> multiply(R(a*.b),Mul(u,v))
      | u,Mul(R(k),v) -> Mul(R(k),Mul(u,v))
      | Mul(R(k),u),v -> Mul(R(k),Mul(u,v))
      | u,v -> multiply(u,v)
    ;;
    Le dérivateur lui-même:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    let rec deriv f =
      match f with
      | X -> R(1.)
      | R(k) -> R(0.)
      | Add(u,R(k)) -> deriv(u)
      | Add(u,v)    -> Add(deriv(u),deriv(v))
      | Mul(R(k),X) -> R(k)
      | Mul(R(k),u) -> product(R(k),deriv(u))
      | Mul(u,v)    -> Add(product(deriv(u),v),product(u,deriv(v)))
      | Sin(u) -> product(deriv(u),Cos(u))
      | Cos(u) -> product(R(-1.),product(deriv(u),Sin(u)))
      | Tan(u) -> product(deriv(u),Power(Cos(u),-2.))
      | Log(u) -> product(deriv(u),Power(u,-1.))
      | Exp(u) -> product(deriv(u),Exp(u))
      | Power(u,2.) -> product(R(2.),product(deriv(u),u))
      | Power(u,b)  -> product(R(b),product(deriv(u),Power(u,b-.1.)))
    ;;

  14. #14
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Une petite fonctionnelle pour fusionner les listes triées:
    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    let map_merge cmp f a b =
      let rec loop a b u =
        match a,b with 
        | [],_ -> List.rev_append u b
        | _,[] -> List.rev_append u a
        | ha::ta,hb::tb ->
            let c = cmp ha hb in
            if c < 0 then loop ta b (ha::u)
            else if c > 0 then loop a tb (hb::u)
            else loop ta tb (f ha hb::u)
      in loop a b [];;
    Fusionner deux int list triées:
    Code :
    1
    2
    let merge_int_list = map_merge (-) (fun a b -> b);;
    merge_int_list [1;3;5] [2;4;6];;
    Fusionner deux (string * int) list triées:
    Code :
    1
    2
    3
    4
    5
    6
    7
    let merge_inventory =
      map_merge
        (fun (pa,_) (pb,_) -> String.compare pa pb)
        (fun (pa,qa) (pb,qb) -> pa,qa+qb);;
    merge_inventory
      ["book",5;"chair",2;"paper",20]
      ["book",2;"paper",50;"pen",1];;
    Les résultats respectifs:
    Code :
    1
    2
    [1; 2; 3; 4; 5; 6]
    [("book", 7); ("chair", 2); ("paper", 70); ("pen", 1)]

  15. #15
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Voici la version corrigée de scale_down_big, c'était cette fonction qui était responsable de l'erreur dans la division Burnikel-Ziegler:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    let scale_down_big (a: big_int) n =
      assert (0 < n & n < base * base);
      let lastr = Array.length a - 1 in
      let accu  = ref 0 
      and carry = ref 0
      and result: big_int = Array.copy a
      in begin
        for i = 0 to lastr do
          accu := a.(i) + !carry * base; 
          result.(i) <- !accu/n; carry := !accu mod n
        done;
        if (result.(0) = 0) && (lastr > 0) then
          (array_sub result 1 lastr: big_int),!carry
        else
          result,!carry
      end;;
    Dans la version erronée j'avais mis Array.sub au lieu de array_sub.

  16. #16
    Membre Expert
    Inscrit en
    avril 2007
    Messages
    831
    Détails du profil
    Informations forums :
    Inscription : avril 2007
    Messages : 831
    Points : 1 130
    Points
    1 130

    Par défaut

    Voici une ré-écriture du code de dérivation en utilisant des facilités syntaxiques. Je n'ai (théoriquement) absolument rien changé au comportement du code.

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    let (+) a b = Add(a,b)
    and ( ^ ) a b = Power(a,b)
    and ( * ) a b =  
      let ( * ) a b = Mul(a,b) in
      let ( *! ) a b = if a = R(1.) then b else a * b in
      match a, b with
      | R(a), Mul(R(b),u) | Mul(R(a),u), R(b) -> R(a*.b) *! u
      | Mul(R(a),u), Mul(R(b),v) -> R(a*.b) *! (u * v)
      | u, Mul(R(k),v) | Mul(R(k),u),v -> R(k) * (u * v)
      | u, v -> u *! v
    
    let rec deriv f =
      match f with
      | X -> R(1.)
      | R(k) -> R(0.)
      | Add(u,R(k)) -> !u
      | Add(u,v)    -> !u + !v
      | Mul(R(k),X) -> R(k)
      | Mul(R(k),u) -> R(k) * !u
      | Mul(u,v)    -> !u * v + u * !v
      | Sin(u) -> !u * Cos(u)
      | Cos(u) -> R(-1.) * (!u * Sin(u))
      | Tan(u) -> !u * (Cos(u) ^ -2.)
      | Log(u) -> !u * (u ^ -1.)
      | Exp(u) -> !u * Exp(u)
      | Power(u,2.) -> R(2.) * (!u * u)
      | Power(u,b)  -> R(b) * (!u * (u ^ (b -. 1.)))
    and ( ! ) f = deriv f
    Après, je ne sais pas si vous trouvez ça plus lisible (redéfinir les opérateurs courant peut aussi provoquer une certaine confusion), c'est un peu une question de goût.

    Les parenthèsages du style a * (b * c) pourraient être évités, mais il changerait le comportement actuel du code qui donne une priorité à droite à la multiplication, et je ne suis pas sûr de son interaction avec le simplicateur.

    On pourrait améliorer les patterns en utilisant la syntaxe révisée, qui utilise une jolie syntaxe curryfiée pour les constructeurs et les types, et je pensque que l'on pourrait même utiliser des pseudos-macros de pattern avec un support camlp4 plus lourd (si LLB passe par ici, il va faire de la propagande ).

  17. #17
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Camlp4 c'est carnaval.

    Avec SpiceGuid les constructeurs ils ont le poil qui brille, et le premier qui commence à paresser ou à curryfier au lieu de construire il se prend un coup de fouet entre les homoplates, nourris à l'ancienne, rien qu'avec des tuples, miam miam les tuples c'est bon mangez en et vous aurez de belles dents.

  18. #18
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Il manquait à ce fil de discussion une vraie fonctionnelle, qui renvoie une fonction utile et néanmoins plus tordue que son argument. Voilà qui est réparé avec lexicographical, un catamorphisme de la fonction compare:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    # let lexicographical cmp =
      let rec loop l1 l2 =
        match l1,l2 with
        | [],[] -> 0
        | [],_ -> -1
        | _,[] ->  1
        | a::t1,b::t2 ->
            let r = cmp a b in
            if r = 0 then loop t1 t2
            else r
      in loop;;
    val lexicographical : ('a -> 'b -> int) -> 'a list -> 'b list -> int = <fun>
    Dans ma tête le type était:
    Code :
    ('a -> 'a -> int) -> ('a list -> 'a list -> int)
    Mais OCaml n'infère pas toujours exactement le type qu'on a en tête (parce qu'on a une intention que le code ne capture pas), en particulier il n'est vraiment pas doué pour placer des parenthèses à droite des flèches.

    Explication:

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    # let lexicographical cmp l1 l2 =
      let rec loop l1 l2 =
        match l1,l2 with
        | [],[] -> 0
        | [],_ -> -1
        | _,[] ->  1
        | a::t1,b::t2 ->
            let r = cmp a b in
            if r = 0 then loop t1 t2
            else r
      in loop l1 l2;;
    val lexicographical : ('a -> 'b -> int) -> 'a list -> 'b list -> int = <fun>
    Pure spéculation: à mon avis à une certaine étape il effectue cette éta-expansion et c'est là que mes parenthèses se perdent.

  19. #19
    Expert Confirmé Sénior
    Avatar de Jedai
    Homme Profil pro
    Enseignant
    Inscrit en
    avril 2003
    Messages
    6 180
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Côte d'Or (Bourgogne)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : avril 2003
    Messages : 6 180
    Points : 8 322
    Points
    8 322

    Par défaut

    Citation Envoyé par SpiceGuid Voir le message
    Dans ma tête le type était:
    Code :
    ('a -> 'a -> int) -> ('a list -> 'a list -> int)
    Mais OCaml n'infère pas toujours exactement le type qu'on a en tête (parce qu'on a une intention que le code ne capture pas), en particulier il n'est vraiment pas doué pour placer des parenthèses à droite des flèches.
    Pourquoi il serait "doué" pour ça ? Il n'y a aucune raison qu'il en place, vu que la flèche est associative à droite, les parenthèses sont donc purement esthétiques.

    --
    Jedaï

  20. #20
    Rédacteur
    Avatar de SpiceGuid
    Homme Profil pro Damien Guichard
    Inscrit en
    juin 2007
    Messages
    1 576
    Détails du profil
    Informations personnelles :
    Nom : Homme Damien Guichard
    Localisation : France, Loire (Rhône Alpes)

    Informations forums :
    Inscription : juin 2007
    Messages : 1 576
    Points : 2 710
    Points
    2 710

    Par défaut

    Cela serait sympathique si on pouvait contrôler cette esthétique, exemples:

    La version qui explicite totalement l'associativité à droite de la flèche (en explicitant l'associativité à gauche de l'application):

    Code :
    1
    2
    3
    4
    5
    # let lexicographical (cmp: 'a -> 'a -> int ) l1 l2 =
      ...
      in ((loop l1) l2);;
    val lexicographical : ('a -> 'a -> int) -> ('a list -> ('a list -> int)) = <fun>
    La version que je voudrais:

    Code :
    1
    2
    3
    4
    5
    # let lexicographical (cmp: 'a -> 'a -> int ) =
      ...
      in (loop);;
    val lexicographical : ('a -> 'a -> int) -> ('a list -> 'a list -> int) = <fun>

Liens sociaux

Règles de messages

  • Vous ne pouvez pas créer de nouvelles discussions
  • Vous ne pouvez pas envoyer des réponses
  • Vous ne pouvez pas envoyer des pièces jointes
  • Vous ne pouvez pas modifier vos messages
  •