Un nouveau programme, plus optimisé

TIPE2021.ml

@@ -196,19 +196,288 @@ let filesize filename = let s = ref 0 and chan = open_in filename in
 (*###############################################################*)
 (*#                      WordMaker-input                       #*)
 (*###############################################################*)
+(*Fréquences de sinnogrammes: https://lingua.mtsu.edu/chinese-computing/statistics/char/list.php?Which=MO*)
 
 let getMotsFromLine = Str.split (Str.regexp " ");;
+(* Caractères qui, enlèvent l'espace à la fin d'un mot: ['- /\@&] exemple: chauve-souris*)
+(* Caractères qui, enlèvent l'espace avant et en placent un après: [:.;,?!%] exemple: Quoi? Vraiment?*)
+
+let ctrlchar = Char.chr 17 ;;
+let ctrl str = (String.make 1 ctrlchar)^str;;
+
+type schartype = SE|SB|SA|CW|SW|Maj|Min|Dig;;
+let getCharType chr = let c=Char.code chr in
+		match c with
+		| c when List.mem c [39;45;47;92;64;38;95;124]            -> SE (* '-/\@&_| *)
+		| c when List.mem c [40;91;123]                           -> SB (* ([{ *)
+		| c when List.mem c [58;59;46;44;33;63;37;36;41;93;125]   -> SA (* :.;,?!%$)]} *)
+		| c when List.mem c [34;35;42;43;60;61;62;94;96;126;9;10] -> CW (* "#*+<=>^`~ <Tab> <Line Feed> *)     (*"*)
+		| 32                                                      -> SW (* <Space> *)
+		| c when 65 <=c && c<=90  -> Maj
+		| c when 97 <=c && c<=122 -> Min
+		| c when 48 <=c && c<=57  -> Dig
+		| _ -> CW;;
+		
+exception NotALetterException;;
+let getMin chr = let ct = getCharType chr in
+	String.make 1 (
+	match ct with
+		| Min|Dig -> chr
+		| Maj -> Char.chr ((Char.code chr)+32)
+		| _ -> raise NotALetterException
+	);;
+
+let getMaj chr = let ct = getCharType chr in
+	String.make 1 (
+	match ct with
+		| Min -> Char.chr ((Char.code chr)-32)
+		| _ -> chr
+	);;
+let getMajChar chr = let ct = getCharType chr in
+	match ct with
+		| Min -> Char.chr ((Char.code chr)-32)
+		| _ -> chr;;
+		
+
+(***
+(* Renvoie les caractères lc et rc de types respectifs lt et rt formatés pret au rajout *)
+(* La nouvelle chaine concaténée est prete pour un nouveau mot.*)
+let ajoutSchar ch lt lc rt rc =
+	match (lt,rt) with
+		| SE,_
+;;
+***)
+
+(***
+let getMotsFromLine str = let mots=ref []
+	and lmot = ref ""
+	and maj = ref false (* Tout est-il en majuscules *)
+	and majed = ref false (* La premiere lettre est-elle en majuscule *) 
+	and inMot = ref false
+	and spaceBefore = ref false
+	and spaceRequested = ref false
+	and lc = nullchar
+	and i = ref 0 in
+while !i < (String.length str) do
+	if !spaceRequested && getCharType.str[i] <> CW
+	then begin
+		(* Si on a demandé un espace et qu'il n'y en a pas *)
+		(* Du coup on écris le caractère avec NOSPACE avant de continuer au traitement normal. *)
+		(* Le cas ou la requete est satisfaite est dans le match ci-dessous *)
+		(* Ben je ne suis pas un espace, alors bon ? on force avec NOSPACE*)
+		inMot := false;
+		mots := (String.make 1 !lc)::(ctrl "NOSPACE")::!mots;
+		lmot := "";
+		spaceBefore := false;
+		spaceRequested := false (* Ben plus maintenant du coup *)
+	end;
+	
+	match getCharType str.[i] in
+		| SW -> (* Un espace en fait *)
+			if !inMot
+			then
+				inMot := false;
+				mots := !lmot::!mots;
+				lmot := "";
+				spaceBefore := true
+			else 
+				if !spaceRequested
+				then
+					mots := (String.make 1 !lc)::!mots;
+					spaceRequested := false
+					spaceBefore := true
+					inMot := false
+				else 
+					###
+		| SE ->
+			if !inMot
+			then
+				lc := str.[i];
+				inMot := false
+			else
+				###
+		| SA ->
+			if !inMot
+			then
+				lc := str.[i];
+				inMot := false;
+				spaceRequested := true
+			else
+				###
+		| SB ->
+			if !inMot
+			then
+				###
+			else
+				if !spaceBefore
+				then
+					mots := (String.make 1 str.[i])::!mots;
+					spaceRequested := false;
+					spaceBefore := false;
+					inMot := false
+				else
+					###
+		| CW ->
+			if !inMot
+			then
+				(* Terminer le mot prématurement et rajouter le mot du caractère CW en espérant un espace *)
+				inMot := false;
+				mots := !lmot::(ctrl "NOSPACE")::(String.make 1 str.[i])::!mots;
+				lmot := "";
+				spaceBefore := false;
+				spaceRequested := true;
+			else
+				if !spaceBefore
+				then
+					(* OK pour l'instant, on prépare le caractère en espérant un espace*)
+					lc := str.[i];
+					inMot := false;
+					spaceRequested := true
+				else
+					(* D'après le if préléminaire, on a spaceRequested=false *)
+					(* On a un CW avec une chaine qui devait etre finie *)
+					###
+		| Maj,Min,Dig -> 
+			if !inMot 
+			then
+				spaceBefore := false;
+				lmot := !lmot^str.[i]
+			else
+				match !lc with
+					| SB | SE -> 
+						mots := (String.make 1 !lc)::!mots;
+						lc := nullchar
+						spaceRequested := false
+						spaceBefore := false
+						inMot := true
+					| _ ->
+				###
+				inMot := true
+			
+	;
+	i := i+1
+done;
+;;**)
+
+let finDeMot lst lmot majed fullmaj nospace =
+	match (majed,fullmaj,nospace) with
+		| (true,_,true) -> (ctrl "NOSPACE")::lmot::(ctrl "FULLMAJ")::lst
+		| (true,_,false) -> lmot::(ctrl "MAJED")::lst
+		| (false,true,true) -> (ctrl "NOSPACE")::lmot::(ctrl "FULLMAJ")::lst
+		| (false,true,false) -> lmot::(ctrl "FULLMAJ")::lst
+		| (false,false,true) -> (ctrl "NOSPACE")::lmot::lst
+		| (false,false,false) -> lmot::lst ;;
+
+let getMotsFromLine str = let mots=ref []
+	and lmot = ref ""
+	and fullmaj = ref false (* Tout est-il en majuscules *)
+	and majed = ref false (* La premiere lettre est-elle en majuscule *)
+	and dansmot = ref false (* As-t-on commencé un mot ? *) in
+for i=0 to (String.length str-1) do
+	match (getCharType str.[i]) with
+		| Maj ->
+			if !dansmot (* Si on ne commence pas un mot *)
+			then
+				if !fullmaj (* Si il n'y a que des majs jusque là *)
+				then 
+					begin
+					majed := false; (* Il n'y a pas QUE la première lettre qui est en maj *)
+					lmot := (!lmot)^(getMin str.[i]) (* On rajoute la lettre *)
+					end
+				else (* La précédente est une minuscule *)
+					begin
+					(* Donc on termine le mot et on met nospace *)
+					mots := finDeMot !mots !lmot !majed !fullmaj true;
+					(* Puis on commence un nouveau mot avec une majuscule *)
+					lmot := getMin str.[i];
+					fullmaj := true;
+					majed := true;
+					dansmot := true
+					end
+			else
+				begin
+				(* Ben on commence un mot avec une majuscule *)
+				lmot := getMin str.[i];
+				fullmaj := true;
+				majed := true;
+				dansmot := true
+				end
+		| Min ->
+			if !dansmot (* Si on ne commence pas un mot *)
+			then
+				begin
+				fullmaj := false; (* Il n'y a pas que des majuscules *)
+				lmot := !lmot^(getMin str.[i]) (* On rajoute la lettre *)
+				end
+			else
+				begin
+				(* On commence un mot avec une minuscule *)
+				lmot := getMin str.[i];
+				majed := false;
+				fullmaj := false;
+				dansmot := true
+				end
+		(* | Dig -> On verra plus tard *)
+		| SW ->
+			if !dansmot
+			then
+				begin
+				(* Ben on finit le mot avec un espace (normal quoi) *)
+				mots := finDeMot !mots !lmot !majed !fullmaj false;
+				dansmot := false;
+				lmot := ""
+				(* Et on passe, le caractère a été rajouté par l'absence de nospace *)
+				end
+			else
+				begin
+				(* On vire le précédent si c'était un NOSPACE, sinon, on rajoute un mot vide, sans NOSPACE*)
+				match (!mots) with
+					| e::l -> (* TODO #001 éviter de vider mots, préférer rajouter un booléen *)
+						if e=(ctrl "NOSPACE") then mots := l else mots := ""::!mots
+					| _ -> 
+						mots := ""::!mots
+				end
+		| _ ->
+			if !dansmot
+			then
+				begin
+				(* On finit le mot, mais avec nospace, puisque le caractère est collé *)
+				mots := finDeMot !mots !lmot !majed !fullmaj true;
+				dansmot := false;
+				lmot := "";
+				(* Puis on rajoute le caractère, avec NOSPACE *)
+				mots := (ctrl "NOSPACE")::(String.make 1 str.[i])::!mots (* TODO #001 *)
+				end
+			else
+				begin
+				(* Idem, mais on a pas le mot à finir *)
+				mots := (ctrl "NOSPACE")::(String.make 1 str.[i])::!mots (* TODO #001 *)
+				end
+	done;
+	mots := finDeMot !mots !lmot !majed !fullmaj false;
+	
+	!mots
+;;
 
 let getMotsFromFile filename = 
 	let mots = ref [] and chan = open_in filename in
 		try
 			while true; do
-				mots := (getMotsFromLine (input_line chan)) @ !mots
+				mots := (ctrl "NEWLINE")::((getMotsFromLine (input_line chan)) @ !mots)
 			done; !mots
 		with End_of_file ->
 	close_in chan;
 	!mots (* A l'envers mais on s'en fiche *);;
 
+let getBytesFromFile filename = 
+	let bits = ref (Bytes.create 0) and chan = open_in filename in
+		try
+			while true; do
+				bits := Bytes.cat (Bytes.of_string (input_line chan))  !bits
+			done; !bits
+		with End_of_file ->
+	close_in chan;
+	!bits (* A l'envers mais on s'en fiche *);;
 
 
 
@@ -253,6 +522,8 @@ let arbreToDict abre =
 
 let dumpDict dict = Dict.iter (fun k v ->
 	printf "\"%s\" -> %s\n" k (bitstringToString v)) dict;;
+
+(* Renvoie une taille du dictionnaire en stockage *)
 let dictSize dict = Dict.fold (fun str bs v -> v+(String.length str)*8+8+(bitSize bs)+8) dict 0;;
 
 
@@ -267,50 +538,111 @@ let encodeMots mots dict  =
 (*#                          Décodeurs                          #*)
 (*###############################################################*)
 
+type bstate = {mutable majed:bool ; mutable fullmaj:bool ; mutable nospace:bool};;
+
+let gstr state mot =
+	let start = if state.nospace then "" else " " in
+	if state.fullmaj
+	then (start^(String.map getMajChar mot))
+	else
+		if state.majed
+		then 
+			match (String.length mot) with
+				| 0 -> start
+				| 1 -> (start^(getMaj mot.[0]))
+				| n -> (start^(String.make 1 (getMajChar mot.[0]))^(String.sub mot 1 (n-1)))
+		else start^mot;;
+let resetstate buffer = 
+	buffer.fullmaj <- false;
+	buffer.majed <- false;
+	buffer.nospace <- false;;
 
 (* A changer pour les mots spéciaux*)
 let addMotToBuffer mot buffer = add_string buffer mot;add_string buffer " ";;
 
-let rec binarintReader arbre0 abre buffer n i =
+let addMotToBuffer mot buffer state = 
+	match mot with
+		| l when l=(ctrl "NOSPACE") -> state.nospace <- true
+		| l when l=(ctrl "MAJED") -> state.majed <- true
+		| l when l=(ctrl "FULLMAJ") -> state.fullmaj <- true
+		| l when l=(ctrl "NEWLINE") -> add_string buffer (gstr state "\n");resetstate state;state.nospace <- true
+		|  _ -> add_string buffer (gstr state mot);resetstate state;;
+
+let rec binarintReader arbre0 abre buffer state n i =
 	match abre with
 		| Feuille(m,p) -> 
-			addMotToBuffer m buffer;print_endline "f";
+			addMotToBuffer m buffer state;print_endline "f";
-			binarintReader arbre0 arbre0 buffer n i 
+			binarintReader arbre0 arbre0 buffer state n i 
 		| Noeud(p,a,b) -> print_endline (string_of_int i);
 			if i>=isize 
 			then abre(* On est au bout du binarint, on peut renvoyer l'état actuel*)
 			else 
 				match (ithBit n i) with
-					| Zero -> binarintReader arbre0 b buffer n (i+1)
+					| Zero -> binarintReader arbre0 b buffer state n (i+1)
-					| Un   -> binarintReader arbre0 a buffer n (i+1) ;;
+					| Un   -> binarintReader arbre0 a buffer state n (i+1) ;;
 
 
-let rec reader arbre0 toReadL buffer=
+let rec reader arbre0 toReadL buffer state=
-	print_endline (string_of_int (Buffer.length buffer));
 	match toReadL with
 		| [] -> arbre0 (* C'est vide, rien à ajouter*)
-		| next::reste -> let abre = reader arbre0 reste buffer in(* On lit d'abord les binarints suivants *)
+		| next::reste -> let abre = reader arbre0 reste buffer state in(* On lit d'abord les binarints suivants *)
-			binarintReader arbre0 abre buffer next 0;;
+			binarintReader arbre0 abre buffer state next 0;;
 
 exception DecodeException;;
 
-let decodeBitstring arbre bs = let buffer = Buffer.create 100 in(*TODO mettre la capacité initiale en paramètre et essayer de la "déduire" de la taille du fichier*)
+let decodeBitstring arbre bs = let buffer = Buffer.create 100 (*TODO mettre la capacité initiale en paramètre et essayer de la "déduire" de la taille du fichier*)
+	and state = {majed=false;fullmaj=false;nospace=true} in
 	match bs with
 		| (i,[]) -> ""
-		| (i,last::toRead) -> let abre = reader arbre toRead buffer in
+		| (i,last::toRead) -> let abre = reader arbre toRead buffer state in
-			let abreFin = binarintReader arbre abre buffer (last >>> (isize-i)) (isize-i) in
+			let abreFin = binarintReader arbre abre buffer state (last >>> (isize-i)) (isize-i) in
 			if abreFin != arbre then raise (DecodeException)
 			else let out = Buffer.contents buffer in Buffer.reset buffer; out;;
-;;
 
 
+(*###############################################################*)
+(*#                      Ligne de commande                       #*)
+(*###############################################################*)
+
+let args = Sys.argv;;
+match Array.length args with
+	| 1 ->
+		print_endline "Coucou ! "
+	| 2 ->
+		let livreFilename = args.(1) in
+		let mots = List.rev (getMotsFromFile livreFilename) in
+		let countmap = motsToCountmap mots in
+		let motpList = countmapToMotsPList countmap in
+		let harbre = construireArbre motpList in
+		let dict = arbreToDict harbre in
+		let encode = encodeMots mots dict in
+		let s = bitSize encode and fs = filesize livreFilename and ds = dictSize dict in
+			printf "%i bits, soit %i octets dont %i pour le dictionnaire sur un fichier de %i octets (%f %% de taux de compression)"
+	 		(s+ds) ((s+ds)/8) (ds/8) fs (100. *. ((float_of_int (s+ds))/. 8. /. (float_of_int fs)))
+	| 3 ->
+		let livreFilename = args.(1) in
+		(*let outName = args.(2) in*)
+		let mots = List.rev (getMotsFromFile livreFilename) in
+		let countmap = motsToCountmap mots in
+		let motpList = countmapToMotsPList countmap in
+		let harbre = construireArbre motpList in
+		let dict = arbreToDict harbre in
+		let encode = encodeMots mots dict in
+		let s = bitSize encode and fs = filesize livreFilename and ds = dictSize dict in
+			printf "%i bits, soit %i octets dont %i pour le dictionnaire sur un fichier de %i octets (%f %% de taux de compression)"
+	 		(s+ds) ((s+ds)/8) (ds/8) fs (100. *. ((float_of_int (s+ds))/. 8. /. (float_of_int fs)));
+		let decode = decodeBitstring harbre encode in
+		print_endline (decode);
+		print_endline "La, je suis censé écrire dans un fichier ?"
+	| _ ->
+		print_endline "Ça fait beaucoup d'arguments ?";;
 
 (*###############################################################*)
 (*#                          Procédure                          #*)
 (*###############################################################*)
 
-let livreFilename = "/home/mysaa/Documents/HistoireDesNombresEtDeLaNumerationNumerique.txt";;
+let livreFilename = "/home/mysaa/Documents/Spigot/merged.java";;
-let mots = getMotsFromFile livreFilename;;
+let mots = List.rev (getMotsFromFile livreFilename);;
 let countmap = motsToCountmap mots;;
 CountMap.find "un" countmap;;
 let motpList = countmapToMotsPList countmap;;
@@ -385,13 +717,13 @@ done;;
 (* Test de rapidité *)
 let t0=Sys.time () in
 let a = of_int 6745678876567878 and b = 12 in
-	for i=0 to 500_000_000 do
+	for i=0 to 500_000 do
 		shift_right a b
 	done;
 	print_endline (string_of_float((Sys.time ())-. t0));
 let t0=Sys.time () in
 let a = 79066342487687576 and b = 12 in
-	for i=0 to 500_000_000 do
+	for i=0 to 500_000 do
 		a lsr b
 	done;
 	print_endline (string_of_float ((Sys.time ())-. t0));;
@@ -408,4 +740,4 @@ done;;
 
 let testListe = [("a",35);("b",10);("c",19);("d",25);("e",06);("f",05)];;
 let out = List.fold_left motMerger (Feuille(("de",3))) testListe;;
-construireArbre testListe;;
+construireArbre testListe;;