(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*               Pierre Weis, projet Cristal, INRIA Rocquencourt       *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  only by permission.                                                *)
(*                                                                     *)
(***********************************************************************)
open Crayon;;

let recule d = avance (-. d)
and tourne_à_droite a = tourne (-. a)
and tourne_à_gauche = tourne;;

let baisse_le_crayon () = fixe_crayon false
and lève_le_crayon () = fixe_crayon true;;

let répète n l =
    for i = 1 to n do l done;;

répète 4 [print_int 1; print_char '*'];;

let répète n liste_d'ordres =
    for i = 1 to n do liste_d'ordres () done;;

répète 4 (function () -> print_int 1; print_char '*');;

type nombre =
   | Entier of int
   | Flottant of float;;

let flottant = function
  | Entier i -> float_of_int i
  | Flottant f -> f;;

type ordre =
   | Av of nombre | Re of nombre
   | Td of nombre | Tg of nombre
   | Lc | Bc
   | Ve
   | Rep of int * ordre list;;

let rec exécute_ordre = function
  | Av n -> avance (flottant n)
  | Re n -> avance (-. (flottant n))
  | Tg a -> tourne (flottant a)
  | Td a -> tourne (-. (flottant a))
  | Lc -> fixe_crayon true
  | Bc -> fixe_crayon false
  | Ve -> vide_écran()
  | Rep (n, l) -> for i = 1 to n do List.iter exécute_ordre l done;;

let exécute_programme l = List.iter exécute_ordre l;;

let carré c = Rep (4, [Av c; Td (Entier 90)]);;

exécute_programme
 [Ve; carré (Entier 100); carré (Entier 75);
  carré (Entier 50); carré (Entier 25);
  carré (Flottant 12.5); carré (Flottant 6.25);
  carré (Flottant 3.125)];;

type lexème =
   | Mot of string
   | Symbole of char
   | Constante_entière of int
   | Constante_flottante of float;;

let flux_car = Stream.of_string "Vive Caml!";;

let flux_ent = [< '2; '3; '5; '7 >];;

stream_next flux_car;;
stream_next flux_car;;

let rec saute_blancs flux =
  match flux with parser
  | [< '' ' >] -> saute_blancs flux  (* ' ' est l'espace *)
  | [< ''\t' >] -> saute_blancs flux (* '\t' est la tabulation *)
  | [< ''\n' >] -> saute_blancs flux (* '\n' est la fin de ligne *)
  | [< >] -> ();;

let rec saute_blancs flux =
  match flux with parser
  | [< ' (' ' | '\t' | '\n') >] -> saute_blancs flux
  | [< >] -> ();;

let rec lire_entier accumulateur flux =
  match flux with parser
  | [< ' ('0' .. '9' as c) >] ->
      lire_entier (10 * accumulateur + int_of_char c - 48) flux
  | [< >] -> accumulateur;;

let flux_car = Stream.of_string "123/456";;

lire_entier 0 flux_car;;

stream_next flux_car;;

lire_entier 900 flux_car;;

let rec lire_décimales accumulateur échelle flux =
  match flux with parser
  | [< ' ('0' .. '9' as c) >] ->
      lire_décimales
        (accumulateur +.
           float_of_int(int_of_char c - 48) *. échelle)
        (échelle /. 10.0) flux
  | [< >] -> accumulateur;;

lire_décimales 123.4 0.01 (Stream.of_string "56789");;

let tampon = String.make 16 '-';;

let rec lire_mot position flux =
  match flux with parser
  | [< '( 'A' .. 'Z' | 'a' .. 'z' | 'é' | 'è' | '_' as c) >] ->
      if position < string_length tampon then
        tampon.[position] <- c;
      lire_mot (position+1) flux
  | [< >] ->
      String.sub tampon 0 (min position (string_length tampon));;
let rec lire_lexème flux =
  saute_blancs flux;
  match flux with parser
  | [< '( 'A' .. 'Z' | 'a' .. 'z' | 'é' | 'è' as c) >] ->
      tampon.[0] <- c;
      Mot(lire_mot 1 flux)
  | [< '( '0' .. '9' as c) >] ->
      let n = lire_entier (int_of_char c - 48) flux in
      begin match flux with parser
      | [< ''.' >] ->
          Constante_flottante
            (lire_décimales (float_of_int n) 0.1 flux)
      | [< >] -> Constante_entière(n)
      end
  | [< 'c >] -> Symbole c;;
let flux_car = Stream.of_string "123bonjour   ! 45.67";;
lire_lexème flux_car;;
lire_lexème flux_car;;
lire_lexème flux_car;;
lire_lexème flux_car;;
let rec analyseur_lexical flux =
 match flux with parser
 | [< l = lire_lexème >] -> [< 'l; analyseur_lexical flux >]
 | [< >] -> [< >];;
let flux_lexèmes =
    analyseur_lexical(Stream.of_string "123bonjour   ! 45.67");;
stream_next flux_lexèmes;;
stream_next flux_lexèmes;;
stream_next flux_lexèmes;;
stream_next flux_lexèmes;;
let nombre = parser
  | [< i = Constante_entière >] -> Entier i
  | [< f = Constante_flottante >] -> Flottant f;;
let flux_lexèmes =
    analyseur_lexical(Stream.of_string "123 1.05 fini");;
nombre flux_lexèmes;;
nombre flux_lexèmes;;
nombre flux_lexèmes;;
let rec ordre = parser
  | [< 'Mot "baisse_crayon" >] -> Bc
  | [< 'Mot "bc" >] -> Bc
  | [< 'Mot "lève_crayon" >] -> Lc
  | [< 'Mot "lc" >] -> Lc
  | [< 'Mot "vide_écran" >] -> Ve
  | [< 'Mot "ve" >] -> Ve
  | [< 'Mot "avance"; n = nombre >] -> Av n
  | [< 'Mot "av"; n = nombre >] -> Av n
  | [< 'Mot "recule"; n = nombre >] -> Re n
  | [< 'Mot "re"; n = nombre >] -> Re n
  | [< 'Mot "droite"; n = nombre >] -> Td n
  | [< 'Mot "td"; n = nombre >] -> Td n
  | [< 'Mot "gauche"; n = nombre >] -> Tg n
  | [< 'Mot "tg"; n = nombre >] -> Tg n
  | [< 'Mot "répète"; n = Constante_entière;
       l = liste_d'ordres >] -> Rep (n,l)
  | [< 'Mot "rep"; n = Constante_entière;
       l = liste_d'ordres >] -> Rep (n,l)
and liste_d'ordres = parser
  | [< 'Symbole '['; l = suite_d'ordres; 'Symbole ']' >] -> l
and suite_d'ordres = parser
  | [< ord = ordre; l_ord = suite_d'ordres >] -> ord :: l_ord
  | [< >] -> [];;
let analyse_programme = parser
  | [< l = suite_d'ordres; 'Symbole '.' >] -> l;;
let lire_code chaîne =
    analyse_programme
      (analyseur_lexical (Stream.of_string chaîne));;
lire_code "répète 4 [avance 100 droite 90].";;
let logo chaîne =
    exécute_programme (lire_code chaîne);;
logo "ve répète 6
           [td 60 répète 6 [av 15 tg 60] av 15].";;
type expression =
   | Constante of nombre
   | Somme of expression * expression
   | Produit of expression * expression
   | Différence of expression * expression
   | Quotient of expression * expression
   | Variable of string;;
let ajoute_nombres = function
  | (Entier i, Entier j) -> Entier (i + j)
  | (n1, n2) -> Flottant (flottant n1 +. flottant n2)
and soustrais_nombres = function
  | (Entier i, Entier j) -> Entier (i - j)
  | (n1, n2) -> Flottant (flottant n1 -. flottant n2)
and multiplie_nombres = function
  | (Entier i, Entier j) -> Entier (i * j)
  | (n1, n2) -> Flottant (flottant n1 *. flottant n2)
and divise_nombres = function
  | (Entier i, Entier j) -> Entier (i / j)
  | (n1, n2) -> Flottant (flottant n1 /. flottant n2)
and compare_nombres = function
  | (Entier i, Entier j) -> i >= j
  | (n1, n2) -> (flottant n1 >=. flottant n2);;
let rec valeur_expr env = function
  | Constante n -> n
  | Somme (e1, e2) ->
     ajoute_nombres (valeur_expr env e1, valeur_expr env e2)
  | Produit (e1, e2) ->
     multiplie_nombres (valeur_expr env e1, valeur_expr env e2)
  | Différence (e1, e2) ->
     soustrais_nombres (valeur_expr env e1, valeur_expr env e2)
  | Quotient (e1, e2) ->
     divise_nombres (valeur_expr env e1, valeur_expr env e2)
  | Variable s -> assoc s env;;
type ordre =
   | Av of expression | Re of expression
   | Td of expression | Tg of expression
   | Lc | Bc
   | Ve
   | Rep of expression * ordre list
   | Stop
   | Si of expression * expression * ordre list * ordre list
   | Exécute of string * expression list;;
type procédure = {paramètres : string list; corps : ordre list};;
let procédures_définies = ref ([] : (string * procédure) list);;
let définit_procédure (nom, proc as liaison) =
    procédures_définies := liaison :: !procédures_définies
and définition_de nom_de_procédure =
    assoc nom_de_procédure !procédures_définies;;
let valeur_entière = function
  | Entier i -> i
  | Flottant f -> failwith "entier attendu";;
exception Fin_de_procédure;;
let rec exécute_ordre env = function
  | Av e -> avance (flottant (valeur_expr env e))
  | Re e -> avance (-. (flottant (valeur_expr env e)))
  | Tg a -> tourne (flottant (valeur_expr env a))
  | Td a -> tourne (-. (flottant (valeur_expr env a)))
  | Lc -> fixe_crayon true
  | Bc -> fixe_crayon false
  | Ve -> vide_écran()
  | Rep (n, l) ->
     for i = 1 to valeur_entière (valeur_expr env n)
     do List.iter (exécute_ordre env) l done
  | Si (e1, e2, alors, sinon) ->
     if compare_nombres (valeur_expr env e1, valeur_expr env e2)
     then List.iter (exécute_ordre env) alors
     else List.iter (exécute_ordre env) sinon
  | Stop -> raise Fin_de_procédure
  | Exécute (nom_de_procédure, args) ->
     let définition = définition_de nom_de_procédure in
     let variables = définition.paramètres
     and corps = définition.corps in
     let rec augmente_env = function
       | [], [] -> env
       | variable :: vars, expr :: exprs ->
          (variable, valeur_expr env expr) ::
          augmente_env (vars, exprs)
       | _ ->
          failwith ("mauvais nombre d'arguments pour "
                    ^ nom_de_procédure) in
     let env_pour_corps = augmente_env (variables, args) in
     try  List.iter (exécute_ordre env_pour_corps) corps
     with Fin_de_procédure -> ();;
type phrase_logo =
   | Pour of string * procédure
   | Ordre of ordre;;
type programme_logo = Programme of phrase_logo list;;
let rec exécute_phrase = function
  | Ordre ord -> exécute_ordre [] ord
  | Pour (nom, proc as liaison) -> définit_procédure liaison
and exécute_programme = function
  | Programme phs -> List.iter exécute_phrase phs;;
let logo chaîne =
    List.iter exécute_phrase
     (analyse_programme
       (analyseur_lexical (Stream.of_string chaîne)));;
logo "pour carré :c
        répète 4 [av :c td 90].
      pour multi_carré :c :n
        répète :n [carré :c td 10].
      ve multi_carré 80 10 .";;
logo "pour spirale :d :a :i :n
       si :n >= 0
        [av :d td :a spirale (:d + :i) :a :i (:n - 1)]
        [stop].";;
logo "ve spirale
      0 179.5 0.5 360 .";;
logo "ve spirale
      0 178.5 0.5 360 .";;
logo "ve spirale
      0 79.8 0.4 360 .";;
logo "ve spirale
      0 79.5 0.4 360 .";;
(* logo "ve spirale -180.0 79.5 0.5 720 .";; *)
logo "pour spirala :d :a :i :n
       si :n >= 0
        [av :d td :a spirala :d (:a + :i) :i (:n - 1)]
        [stop].";;
(* logo "ve spirala 10 0 2.5 90 .";; *)
logo "ve spirala
      5 0 89.5 1440 .";;
logo "ve spirala
      4 0.5 181.5 1500 .";;

