COMPILATEUR V 0.9 beta 10 du 29 aout 2017

' teste d'essai codage fichier source.
error_french
label ouvrir , sauver , codage , lecturage , enydata, lireytable , sauverytable , ouvriryfichierycoder , copie , sauveytexte , decode , lecture , melange

width 0,1200:height 0,screen_y   :'    full_space 0

dim  n% , w% , new%
dim source$ , f$ , coder$ , code$
dim a% , aa$
dim b% , bb$
dim c% , cc$ , cp%
dim d$ , dat$  
dim u$ , table$ , v%  ,m$ , lig%
dim tx$ ,i% , s$ , e%  

w% = width(0)-80
font_size 0,10 : font_bold 0 : font_name 0,"Consolas"  : height 0,520
dlist 1:'          width 1,w%:height 1,110  :bar_both 1  : hint 1,"code()"

dlist 2:' parent 2,50:full_space 2:' top 2,120:width 2,w%:height 2,110               : hint 2,"melange()"
dlist 3:' top 3,240:width 3,w%:height 3,110               : hint 3,"decode()"
memo 4: top 4,210:width 4,w%:height 4,height(0)-200-80 : bar_both 4     : hint 4,"lecture"
dlist 5:' left 5,w%+1 : height 5,800 : width 5,w%
dlist 6:' left 6,10:top 6,460: width 6,500 : height 6,800 : font_size 6,14 : font_name 6,"Consolas": color 6,240,240,240
memo 7 :width 7,width(0)-30:height 7,200   : bar_both 7
n%=8   :' nb de code par N°  
open_dialog 10    
main_menu 15
sub_menu 16   :parent 16,15 : caption 16,"Fichier"
   sub_menu 17:parent 17,16 : caption 17,"Ouvrir un fichier à coder"        : on_click 17,ouvrir
   sub_menu 33:parent 33,16 : caption 33,"-"
   sub_menu 14:parent 14,16 : caption 14,"Ouvrir un fichier déjà codé"      : on_click 14,ouvriryfichierycoder
   sub_menu 18:parent 18,16 : caption 18,"Enregistrer un fichier codé"      : on_click 18,sauver
   sub_menu 32:parent 32,16 : caption 32,"-"
   sub_menu 19:parent 19,16 : caption 19,"Créer une table de codage"        : on_click 19,enydata
   sub_menu 30:parent 30,16 : caption 30,"Lire une table de codage"         : on_click 30,lireytable
   sub_menu 31:parent 31,16 : caption 31,"Sauver une table de codage"       : on_click 31,sauverytable

sub_menu 20   :parent 20,15 : caption 20,"   Travail   "
   sub_menu 21:parent 21,20 : caption 21,"Codage du fichier"                : on_click 21,codage
   sub_menu 24:parent 24,20 : caption 24,"-"
   sub_menu 22:parent 22,20 : caption 22,"Lecture en clair du fichier codé" : on_click 22,lecturage
   sub_menu 23:parent 23,20 : caption 23,"Copier dans presse-papier du fichier décodé"        : on_click 23,copie
   sub_menu 25:parent 25,20 : caption 25,"Sauvegardé le fichier décodé"     : on_click 25,sauveytexte
gosub lireytable
end

' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&  
ENYDATA:
   clear 5 : clear 6
   for a% = 123 to 123 + 16*n%
      aa$ = chr$(a%)
      item_add 5,aa$
   next a%
   ' ------------------------------
   for a% =0 to 15
      aa$ = hex$(a%)
      dat$ = aa$
      ' on compose 16 lignes
      for b% = 1 to n%
         if count(5) > 1
            v% =  rnd(count(5)-1)+1
            bb$ = item_read$(5,v%)
            dat$ = dat$ +bb$
            item_delete 5,v%
         end_if
      next b%
      item_add 6,dat$
   next a%
   caption 0,"table de codage crée"
   ' ------------------------------
   clear 5    
   file_save 6,"donner_data.ini"
   if new% = 0 then message "table de codage créer et sauvegardé"
return
' ===================================================================
LIREYTABLE:
   if file_exists("donner_data.ini") = 1 then file_load 6,"donner_data.ini"
   caption 0,"Table lue"
return
' ..................
sauverytable:
   if file_exists("donner_data.ini") = 1
      if message_warning_yes_no("ATTENTION! Si la table existe, elle écrasera la précédente"+chr$(13)+"les fichiers codés avec cette table ne pourront plus êtes lues") = 1
         file_save 6,"donner_data.ini"
      end_if
   else
      file_save 6,"donner_data.ini"
   end_if
return
' ..................
ouvriryfichierycoder:
   clear 1 : clear 2 : clear 3 : clear 4
   coder$ = file_name$(10)
   if coder$ <> "_"
      file_load 2,coder$  : caption 0,"Fichier codé: "+ coder$+ " lue, près à être décodé"
      gosub decode : gosub lecture
   end_if                
return
' ==============================================================
lecturage:
   clear 3
   gosub decode
   gosub lecture
return      
' =============================================================
LECTURE:
   ' hide 4
   if count(3) > 0
      caption 0,"démarrage de la lecture"
      for a% = 1 to count(3)
         aa$ = item_read$(3,a%) : tx$=""
         aa$ = right_pos$(aa$,6)
         for b% = 1 to len(aa$) step 2
            bb$ = mid$(aa$,b%,2)  : caption 0,str$(a%)+"|aa$:"+aa$+"|b%="+str$(b%)+"| "+left$(bb$,1) + "  "+right$(bb$,1)
            i% = hex(bb$)
            tx$ = tx$ +chr$(i%)
         next b%
         item_add 4,tx$
      next a%
      caption 0,"fichier décodé en clair"
   else
      caption 0,"fichier vide"
    end_if
    show 4
return
' ===================================================  
DECODE:
   caption 0,"Démarrage du décodage"
   if count(2) > 0
      ' on extrait en premier les lignes
       aa$ = item_read$(2,1) :' normalement entier
       clear 2
       repeat
          v% = instr(aa$,chr$(254))
          if v% > 0
             bb$ = left$(aa$,v%-1) : bb$ = right_pos$(bb$,21)
             aa$ = right_pos$(aa$,v%+1)
             item_add 2,bb$  : bb$= ""
          end_if
       until v% = 0              
      ' puis on extrait la table de codage des 16 premières lignes à mettre en 6
      aa$ = item_read$(2,1)
      table$ = left$(aa$,144)
      item_delete 2,1  : clear 6
      for a%= 1 to 144 step 9
         aa$ = mid$(table$,a%,9)
         item_add 6,aa$
      next a%

      for a% = 1 to count(2)
         aa$ = item_read$(2,a%)  
         cc$ = ""
         for b% = 1 to len(aa$)
            bb$ = mid$(aa$,b%,1)   : u$=""
            for c% = 1 to count(6)
               if instr(item_read$(6,c%),bb$) > 0
                  cc$ = cc$ + left$(item_read$(6,c%),1)  : u$ = left$(item_read$(6,c%),1)
                  exit_for
               end_if
            next c%
         next b%
         aa$ = cc$      
         cc$ = left$(aa$,3) + right_pos$(aa$,9)
         bb$ = mid$(aa$,4,5)
         d$ = bb$ + cc$
         item_add 3,d$
      next a%
      sort 3
      caption 0,"fichier décodé, près à être lu"
   else
      caption 0,"Pas de fichier à décoder!"
   end_if
return      
' ===================================================================
sauver:
   f$ = file_name$(10)
   if f$ <> "_" then file_save 2,f$ : caption 0,"Fichier: " + f$ +" sauvegardé"
return
' ===================================================================
copie:
   if count(4) > 0
      n%=0
      for a% = 1 to count(4)
         aa$ = item_read$(4,a%)
         n% = n% + len(aa$)+2
      next a%
      select_text 4,1,n%+10
      clipboard_string_copy select_read$(4)
   end_if
return  
' ===================================================================
sauveytexte:
   f$ = file_name$(1)
   if f$ <> "_" then file_save 4,f$ : caption 0,"fichier: "+f$+"  enregistré"
return
' ====================================================================
codage:
   new%=1
   if count(6) = 0 then gosub enydata
   if count(7) > 0
      caption 0,"démarrage du codage"
      clear 2 : clear 3 : clear 4
      for e% = 1 to count(7)
         caption 0,"FOR: "+ str$(a%)
         s$ = item_read$(7,e%) : caption 0,"s$="+s$
         ' ==================================
         lig% = count(1)+1
         aa$ = right$("00000"+hex$(lig%),5)

         for a% = 1 to len(s$)
            bb$ = mid$(s$,a%,1)
            cc$ = right$("00"+hex$(asc(bb$)),2)
            aa$ = aa$ + cc$
         next a%
         item_add 5,aa$
         ' on essaye de mélanger selon 6
         code$ = "0123456789ABCDEF"
         dat$ = ""
         for a% = 1 to len(aa$)
            bb$ = mid$(aa$,a%,1)
            v% = instr(code$,bb$)
            i% = rnd(n%)+1
            dat$ = dat$ + mid$(item_read$(6,v%),i%,1)
         next a%

         item_add 1,dat$
         ' ==================================
      next e%
      gosub melange
      ' bien on rajoute alors un fin de ligne avec code: üýþÿ  ou alors rajouter devant un nb de caractères inutile
      caption 0,"Fin du codage"
   else
      caption 0 ,"Pas de fichier à lire pour être codé"
   end_if
return
' ===================================================================
ouvrir:
   clear 1 : clear 2 : clear 3 : clear 4
   f$ = file_name$(10)
   if f$ <> "_" then file_load 7,f$ : caption 0,"Fichier: "+ f$ +" ouvert"
return
' =================================================================
         ' on change la position des N° de ligne
MELANGE:
 '  dim_local aa$,b$,a%,cc$,d$ , tx$ , cp%
   caption 0,"Mélange du fichier"
   sort_on 2
   if count(1) > 0
      for a% = 1 to count(1)
         aa$ = item_read$(1,a%)
         bb$ = left$(aa$,5)
         cc$ = right_pos$(aa$,6)
         d$ = left$(cc$,3)
         d$ = d$ + bb$
         d$ = d$ + right_pos$(cc$,4)
         item_add 2,d$
      next a%
      sort 2    
      aa$ = ""
      ' mettre devant les 16 lignes de codage
      for a% = 1 to 16
         bb$ = item_read$(6,a%)
         aa$ = aa$ + bb$
      next a%
      item_insert 2,1,aa$
      ' mettre devant les caractères qui cachent l'ordre des lignes
      d$ = "2öÄÓÓÂ×¢ˆÄ}Ä} ë±í¤ÃÖå”Û—´”¥”× ¢“ÂÈ€¿²È¯éÒÔ“ø›¶œÂœîç‡ÈÊ—§”é—·—£6¡ß ¾‰ÅœÂ6¼Ñű³ŸÖ‹ÂεùàÀôÁ¤Ü¤¡“Ó—Ž¯2ˆ¤…Ѯ燤±Ñ¯ª‚؍ëà欄çö 5”Õ‹ˆ”3”嵡žÄà÷"

      for a%=1 to count(2)
         aa$ = item_read$(2,a%)
         bb$ = mid$(d$,int(rnd(100)+1),20)
         ' ajouter à chaque ligne un caractère de changement de ligne
         aa$= bb$+aa$    + chr$(254)
         tx$ = tx$ +aa$
      next a%

      ' reformer le fichier
      clear 2
      item_add 2,tx$

      caption 0,"Fichier mélangé"
   else
      caption 0,"List 1 vide, fonction annulée"
   end_if
return
' ===================================

rem ============================================================================
rem                    Vagues
rem ============================================================================
DIM NombreVague , VitesseVague
DIM PASX ,PASY,x,y,ix,iy,r,g,b
NombreVague = 200 : VitesseVague = 20 : PASX = 5 : PASY = 5
width 0,700 : height 0,500
caption 0,"<ESC> pour terminer"
while 2 + 3 = 5
    x = x + VitesseVague : y = y + VitesseVague
    FOR IY = 0 TO height(0) STEP PASX
        FOR IX = 0 TO width(0) STEP PASY
            r = mod(ix+x+iy+y,255)
            g = mod(ix+x+iy+y,NombreVague)
            b = mod(ix+x+iy+y,255)
            2d_pen_color r,g,b : 2d_fill_color r,g,b : 2d_circle ix,iy,5
          '  if scancode = 27 then terminate
            if scancode <> 0 then terminate
        NEXT ix        
    NEXT iy
end_while
rem ============================================================================

label fin
button 1
on click 1,fin
end
fin:
terminate
return

' Essai Compilateur EssaiCompilateur.bas
' Lanceur
error_french : application_title "Essai Compilateur"

dir_change dir_current$
DeclarationDim() : Obj() 
' 1) Controle existence Répetoire du programme
' ..... à voir

' 2) Controle existence Fichier des Utilisateurs
if file_exists("FichierUtilisateurs")=0
  InputFirstUser()
else 
  Accede()
end_if

END

rem == COMPILATION IMPOSSIBLE (pour que cela fontionne il faut déplacer ce bloc de sous-programmes après la SUB Obj() en ligne 58 )
SortiePanel1:
  hide Panel1%
RETURN
 
ValidePanel1:
  message "  à terminer  "
RETURN

rem ============================================================================
SUB DeclarationDim()
    dim no%,Panel1%,Alpha0%,Alpha1%,Edit1%,BtAbandon1%,BtValide1%
    dim a$
END_SUB
' -------------------
SUB Obj()
  ' Form 0
    caption 0,"Essai Compilateur" : color 0,0,0,0
    top 0,(screen_y-height(0))/2 : left 0,(screen_x-width(0))/2
  ' Panel1%
    no%=no%+1 : Panel1%=no% : panel no% : hide no%
                width no%,300 : height no%,300 : color no%,150,220,255
                top no%,(height(0)-height(no%))/2 : left no%,(width(0)-width(no%))/2
    no%=no%+1 : Alpha0%=no% : alpha no% : parent no%,Panel1% : caption no%,"Inscription Premier Utilisateur."
                font_name no%,"Arial" : font_size no%,12 : font_bold no% : top no%,10: left no%,30
    no%=no%+1 : Alpha1%=no% : alpha no% : parent no%,Panel1% : caption no%,"Identifiant: "
                font_name no%,"Arial" : font_size no%,11 : font_bold no% : top no%,60: left no%,10
    no%=no%+1 : Edit1%=no% : edit no% : parent no%,Panel1% : width no%,190 : color no%,220,220,55
                top no%,top(Alpha1%) : left no%,left(Alpha1%)+width(Alpha1%)
    no%=no%+1 : BtAbandon1%=no% : button no% : parent no%,Panel1% : caption no%,"Adandon"             
                font_bold no% : top no%,height(Panel1%)-30 : left no%,10
    no%=no%+1 : BtValide1%=no% : button no% : parent no%,Panel1% : caption no%,"Valider"             
                font_bold no% : top no%,top(no%-1) : left no%,width(Panel1%)-width(no%)-10
  ' Evènement Panel1%
    label SortiePanel1,ValidePanel1
    on_click BtAbandon1%,SortiePanel1
    on_click BtValide1%,ValidePanel1
   
END_SUB
rem ============================================================================
SUB InputFirstUser()
    a$="Bonjour et bienvenue dans Essai Compilateur."+chr$(13)+chr$(13)
    a$=a$+"Pour commencer vous devrez entrer votre nom d'utilisateur."+chr$(13)+"(Exemple: DUPONT Jean, ...)"+chr$(13)+chr$(13)
    a$=a$+"En tant que premier utilisateur du logiciel vous en êtes, d'office, l'administrateur."
    message a$ : show Panel1%
END_SUB
' -------------------
SUB Accede()

END_SUB

' essai compilateur

' Tel quel ce code ne peut pas être compilé (voir copie du fichier error.txt ci-dessous).

rem fichier error.txt ==========================================================
' Nouveau_1.bas(58) error 33: Expected 'END IF', found 'End'
' End Sub
'     ^
' Nouveau_1.bas(59) error 58: Illegal inside functions, found 'declare'
' declare function WinMain _
' ^
' Nouveau_1.bas(64) error 67: Array not dimensioned, before '('
' end WinMain(GetModuleHandle(null),null,Command(),SW_NORMAL)
            ^
' Nouveau_1.bas(65) error 58: Illegal inside functions, found 'function'
' function WndProc _
rem ============================================================================

' Si on supprime le RETURN de la ligne 28 la compilation est OK
rem CODE =======================================================================
edit 1
button 2 : caption 2,"valider" : top 2,30
label Valide
on_click 2,Valide
END

Valide:
  if len(text$(1))<3 then message "3 caractères minimum" : text 1,"" : RETURN
  ' suite si len(text$(1))>2 (par exemple enregistrer)
RETURN