Stimulus 04 Exemple

par **Shadow272** Lun 16 Nov - 15:12

Code:: RESERVE IF FRE()<204800 ~FORM_ALERT(1,"[1][| M‚moire insuffisante | ou fragment‚e. |][Quitter]") EDIT ELSE ON BREAK GOSUB sortir init1 init2 init3 boucle_generale ENDIF ' > PROCEDURE sortir ~MENU_BAR(adtree%(0),0) ~GRAF_MOUSE(0,0) ferme_win(1) ! rien que des fermetures fenˆtre IF m_adr% ~GEMDOS(73,L:m_adr%) ! m‚moire ENDIF ~RSRC_FREE() ! ressource ~APPL_EXIT() ! simul‚ par le GFA, mais on le met quand mˆme ' EDIT ! on revient … l'‚diteur QUIT 0 ! ou on quitte RETURN ' > PROCEDURE init1 ap_id&=APPL_INIT() ! r‚cup‚ration identificateur de notre programme IF ap_id&<0 ! si probleme sortir ! alors on sort proprement ENDIF ' ~GRAF_MOUSE(0,0) ! on r‚tablie la forme de la souris (pointeur) ' ~WIND_UPDATE(1) ! blocage de l'AES au niveau du menu et de la ~WIND_UPDATE(3) ! souris pour le Screen manager ' ~WIND_GET(0,4,screenx&,screeny&,screenl&,screenh&) ! coordonn‚es de l'‚cran ' magic!=@test_cookie("MagX",dummy%) ! on regarde dans la Cookie Jar mint!=@test_cookie("MiNT",dummy%) ! sous quel AtariOS on est IF ap_id&>0 AND (magic! OR mint!) ! si ap_id&=0 : on est sur d'etre en monotache multi!=TRUE ! petit flag pour savoir si on est en multitache ou pas ELSE multi!=FALSE ENDIF ' @declare ! d‚claration des variables, tableaux et chaŒnes de texte remplies ' ! vous pouvez faire un a$=SPACE$(32000) ' RESERVE 15360 ! r‚servation 15360 octets qui correspond … la marge ' ' on peut nettoyer son a$ si on veut ' @declare_mem ! on va y faire des MALLOC (GEMDOS(72,L:taille%) ' ! maintenant, interdiction de faire un gros tableau ' ! ou un a$=SPACE$(32000) ' IF @s_exist(chemin$+exemple_rsc$)=TRUE ! test la pr‚sence du RSC sur disque result%=RSRC_LOAD(chemin$+exemple_rsc$) ! on le charge IF result%=0 ! si problŠme ~FORM_ALERT(1,"[1][EXEMPLE.RSC n'a pas pu| ˆtre charg‚ comme fichier| ressource.][ Ok ]") sortir ! alerte et on sort ELSE ! sinon FOR i%=0 TO nb_tree% ! on r‚cupŠre les adresses des arbres ~RSRC_GADDR(0,i%,adtree%(i%)) IF i%>0 hd&(i%)=OB_H(adtree%(i%),0) ld&(i%)=OB_W(adtree%(i%),0) ENDIF NEXT i% ENDIF ELSE ! si le ressource n'est pas … c“t‚ du programme ~FORM_ALERT(1,"[1][|EXEMPLE.RSC non trouv‚.][ Ok ]") sortir ENDIF ' RETURN > PROCEDURE declare lect%=GEMDOS(25) ! donne un chiffre ui correspond au lecteur (0=A, 1=B...) chemin$=CHR$(lect%+65)+":"+DIR$(lect%+1)+"" ! construction du chemin de EXEMPLE.PRG c0$=CHR$(0) ! truc sympa pour bricoler ses chaŒnes C ' exemple_rsc$="EXEMPLE.RSC"+c0$ ! nom du fichier ressource ' nb_tree%=3 ! nombre d'arbres en tout ' DIM adtree%(nb_tree%),xd&(nb_tree%),yd&(nb_tree%),ld&(nb_tree%),hd&(nb_tree%) DIM hand_win%(nb_tree%),wx&(nb_tree%),wy&(nb_tree%),wl&(nb_tree%),wh&(nb_tree%) ' ' adtree%()=adresse arbre ' ?d&()=coordonn‚es AES de l'objet 0 de l'arbre ' hand_win%() = identificateur (handle) de la fenˆtre qui peut contenir l'arbre ' w?&()= coordonn‚es externes de la fenˆtre ' DIM win!(nb_tree%),cp_win%(nb_tree%),aff!(nb_tree%) ' ' win!()=existence de la fenˆtre ' cp_win%()= composants de la fenˆtre (champ de bits) ' aff!()= si je dois afficher … l'int‚rieur de la fenˆtre ' FOR i%=0 TO nb_tree% ! on met tout … 0 win!(i%)=FALSE aff!(i%)=FALSE cp_win%(i%)=0 NEXT i% ' cp_win%(1)=&X111111101111 ! sauf la fenˆtre 1 qui contient le deuxiŠme arbre (1) ' RETURN > PROCEDURE declare_mem ' m_adr%=GEMDOS(72,L:16) ! on se r‚serve un buffer de 16 octets IF m_adr%<1 ! qui va servir … r‚cup‚rer les messages sortir ! du Screen manager. ENDIF ! si problŠme, on sort ' RETURN > PROCEDURE init2 ' ' traitement des objects avant leur utillisation r‚elle. ' ' on va les mettre en 3D si on est sous MagiC IF magic! FOR i%=1 TO nb_tree% FOR j%=0 TO OB_TAIL(adtree%(i%),0) ! on va jusqu'au dernier des fils de l'objet 0 SELECT OB_TYPE(adtree%(i%),j%) ! on regarde un peu le type de l'objet CASE 20,23,22,26,27,30 OB_FLAGS(adtree%(i%),j%)=BSET(OB_FLAGS(adtree%(i%),j%),9) ! hop, 3D ENDSELECT NEXT j% NEXT i% ENDIF ' ' on nettoye ce que contient (ici du texte) les objet de l'arbre 1 ' CHAR{{OB_SPEC(adtree%(1),6)}}="" CHAR{{OB_SPEC(adtree%(1),8)}}="" CHAR{{OB_SPEC(adtree%(1),9)}}="" CHAR{{OB_SPEC(adtree%(1),10)}}="" CHAR{{OB_SPEC(adtree%(1),14)}}="" CHAR{{OB_SPEC(adtree%(1),16)}}="" CHAR{{OB_SPEC(adtree%(1),18)}}="" CHAR{{OB_SPEC(adtree%(1),20)}}="" CHAR{{OB_SPEC(adtree%(1),22)}}="" CHAR{{OB_SPEC(adtree%(1),24)}}="" CHAR{{OB_SPEC(adtree%(1),26)}}="" CHAR{{OB_SPEC(adtree%(1),28)}}="" CHAR{{OB_SPEC(adtree%(1),32)}}="" CHAR{{OB_SPEC(adtree%(1),34)}}="" CHAR{{OB_SPEC(adtree%(1),36)}}="" CHAR{{OB_SPEC(adtree%(1),38)}}="" CHAR{{OB_SPEC(adtree%(1),40)}}="" ' RETURN > PROCEDURE init3 ' ~WIND_UPDATE(2) ! on rend la main au Screen manager ~WIND_UPDATE(0) ' ~MENU_BAR(adtree%(0),1) ! on active la barre de menu (1er arbre: 0) ' IF multi!=FALSE ! si on est pas en multitache ' ' on pr‚vient le GEM qu'il faut redessiner l'‚cran avec les coordonn‚es ' ci-dessous: c-a-d l'‚cran de travail entier ' ~FORM_DIAL(3,0,0,0,0,screenx&,screeny&,screenl&,screenh&) ENDIF ' win(1) ! on oure la fenˆtre au d‚part ' RETURN ' > PROCEDURE boucle_generale ! boucle sans fin qui va tout scruter DO evnt&=EVNT_MULTI(&X110011,2,1,1,0,0,0,0,0,0,0,0,0,0,m_adr%,3000,mo_x&,mo_y&,mo_k&,m_touche%,m_clavier%,mo_c&) ' CHAR{{OB_SPEC(adtree%(1),40)}}=BIN$(evnt&,6) ' IF BTST(evnt&,0) CHAR{{OB_SPEC(adtree%(1),32)}}=BIN$(m_touche%,4) CHAR{{OB_SPEC(adtree%(1),34)}}=STR$(m_clavier%) dummy%=BYTE(m_clavier%) IF dummy%=17 ! ^Q sortir ENDIF CHAR{{OB_SPEC(adtree%(1),36)}}=CHR$(dummy%)+"="+STR$(dummy%) CHAR{{OB_SPEC(adtree%(1),38)}}="&H"+HEX$((m_clavier% AND &HFF00)/&H100,2) ENDIF ' IF BTST(evnt&,1)=TRUE ' CHAR{{OB_SPEC(adtree%(1),6)}}=STR$(mo_x&) CHAR{{OB_SPEC(adtree%(1),8)}}=STR$(mo_y&) CHAR{{OB_SPEC(adtree%(1),9)}}=STR$(mo_k&) CHAR{{OB_SPEC(adtree%(1),10)}}=STR$(mo_c&) ' clic_win%=WIND_FIND(mo_x&,mo_y&) IF clic_win%=hand_win%(1) AND win!(1)=TRUE boucle_generale_suite ENDIF ENDIF ' IF BTST(evnt&,4)=TRUE ' m_type&=INT{m_adr%} ! on r‚cupŠre ce qu'il y a dans le buffer m_id&=INT{m_adr%+2} m_dummy&=INT{m_adr%+4} m_6&=INT{m_adr%+6} m_8&=INT{m_adr%+8} m_10&=INT{m_adr%+10} m_12&=INT{m_adr%+12} m_14&=INT{m_adr%+14} ' CHAR{{OB_SPEC(adtree%(1),14)}}=STR$(m_type&) CHAR{{OB_SPEC(adtree%(1),16)}}=STR$(m_id&) CHAR{{OB_SPEC(adtree%(1),18)}}=STR$(m_dummy&) CHAR{{OB_SPEC(adtree%(1),20)}}=STR$(m_6&) CHAR{{OB_SPEC(adtree%(1),22)}}=STR$(m_8&) CHAR{{OB_SPEC(adtree%(1),24)}}=STR$(m_10&) CHAR{{OB_SPEC(adtree%(1),26)}}=STR$(m_12&) CHAR{{OB_SPEC(adtree%(1),28)}}=STR$(m_14&) ' SELECT m_type& CASE 10 ! MENU_SELECTED boucle_menu CASE 20 ! WM_REDRAW redraw CASE 21 ! WM_TOPPED win_topped CASE 29,31 ! WM_TOP, WM_ONTOP CASE 22 ! WM_CLOSED CASE 23 ! WM_FULLED CASE 24 ! WM_ARROWED CASE 26 ! WM_SLIDED CASE 28 ! WM_MOVED win_moved CASE 27 ! WM_SIZED CASE 34 ! WM_ICONIFY CASE 35 ! WM_UNICONIFY CASE 50 ! SHUT_DOWN shut_down CASE 63 ! DRAGDROP CASE 18193 ! VA_START CASE 22360 ! WM_SHADOWED IF m_fenetre&=hand_win%(1) AND win!(1)=TRUE aff!(1)=FALSE ENDIF CASE 22361 ! WM_UNSHADOWED IF m_fenetre&=hand_win%(1) AND win!(1)=TRUE aff!(1)=TRUE ENDIF ENDSELECT ' ENDIF IF BTST(evnt&,5) INC forme% IF forme%=8 forme%=0 ENDIF ~GRAF_MOUSE(forme%,0) ENDIF ' IF BTST(evnt&,0) black_white(1,32,0) black_white(1,34,0) black_white(1,36,0) black_white(1,38,0) ENDIF IF BTST(evnt&,1) black_white(1,6,0) black_white(1,8,0) black_white(1,9,0) black_white(1,10,0) ENDIF IF BTST(evnt&,4) black_white(1,14,0) black_white(1,16,0) black_white(1,18,0) black_white(1,20,0) black_white(1,22,0) black_white(1,24,0) black_white(1,26,0) black_white(1,28,0) ENDIF ' black_white(1,40,0) ' FOR i%=0 TO 3 ! nettoyage du buffer LONG{m_adr%+i%*4}=0 NEXT i% ' LOOP RETURN > PROCEDURE boucle_generale_suite IF clic_win%=hand_win%(1) AND win!(1)=TRUE gere_interieur_fenetre ENDIF RETURN > PROCEDURE boucle_menu ~MENU_TNORMAL(adtree%(0),m_6&,1) ! je remet l'item titre du menu en normal SELECT m_8& CASE 7 info CASE 16 win(1) CASE 18 ferme_win(1) CASE 20 sortir ENDSELECT RETURN ' > PROCEDURE win(dial&) ! fonction custom, si elle existe, on l'active IF win!(dial&) ! sinon on la cr‚‚e force_top(dial&) ELSE IF win!(dial&)=FALSE create_win(dial&) ENDIF ENDIF RETURN > PROCEDURE create_win(dial&) hand_win%(1)=@window_create(cp_win%(1)) ! le WIND_CREATE GFA est bugge, remplace par un vrai propre, voir plus bas IF hand_win%(1)>0 ! si ok win!(1)=TRUE ' centrage arbre 1, permet d'obtenir les coord de l'objet 0 ~FORM_CENTER(adtree%(1),xd&(1),yd&(1),dummy%,dummy%) ' on donne un titre, la chaŒne se trouve dans le ressource arbre (nb_tree%=4) avec objet 1 ~WIND_SET(hand_win%(1),2,CARD(SWAP(OB_SPEC(adtree%(nb_tree%),1))),CARD(OB_SPEC(adtree%(nb_tree%),1)),0,0) ' on calcule … partir des composantes internes les compasantes externes ~WIND_CALC(0,cp_win%(1),xd&(1),yd&(1),ld&(1),hd&(1),wx&(1),wy&(1),wl&(1),wh&(1)) ' petits r‚glages wx&(1)=MAX(screenx&+1,wx&(1)) wy&(1)=MAX(screeny&+1,wy&(1)) ' au cas o— l'arbre aurait chang‚ de place move_win(1,wx&(1),wy&(1),wl&(1),wh&(1)) ' petite propri‚t‚, plus besoin d'activer la fenˆtre pour y acc‚der … son contenu ~WIND_SET(hand_win%(1),24,&X1,0,0,0) ' on l'ouvre finalement dummy%=WIND_OPEN(hand_win%(1),wx&(1),wy&(1),wl&(1),wh&(1)) IF dummy%=0 ! ‚chec win!(1)=FALSE ENDIF aff!(1)=win!(1) ELSE ~FORM_ALERT(1,CHAR{OB_SPEC(adtree%(nb_tree%),2)}) ! plus de fenˆtres win!(1)=FALSE aff!(1)=FALSE ENDIF RETURN > PROCEDURE ferme_win(dial&) IF win!(dial&)=TRUE ~WIND_CLOSE(hand_win%(dial&)) ! on ferme ~WIND_DELETE(hand_win%(dial&)) ! et on la d‚truit. win!(dial&)=FALSE ! €a permet de lib‚rer la m‚moire aff!(dial&)=FALSE ENDIF RETURN > PROCEDURE move_win(dial&,x0&,y0&,l0&,h0&) ! fonction par moi-mˆme IF win!(1)=TRUE ! permet … partir des coordonn‚es ' ! externe d'avoir les internes ~WIND_CALC(1,cp_win%(1),x0&,y0&,l0&,h0&,xd&(1),yd&(1),dummy%,dummy%) OB_X(adtree%(1),0)=xd&(1) OB_Y(adtree%(1),0)=yd&(1) ' ' €a sert … d‚placer l'arbre si la fenˆtre a boug‚e ' ENDIF RETURN > PROCEDURE black_white(arbre%,fils%,etat%) ! fonction custom ' ' je change l'‚tat de mon objet(=fils%) dans l'abre% ' et je le redessine en respectant la liste ddes rectangles (REDRAW) ' SELECT etat% ! selon ‚tat, on modifie l'object CASE 0 OB_STATE(adtree%(arbre%),fils%)=BCLR(OB_STATE(adtree%(arbre%),fils%),0) CASE 1 OB_STATE(adtree%(arbre%),fils%)=BSET(OB_STATE(adtree%(arbre%),fils%),0) ENDSELECT ' SELECT arbre% CASE 1 ~WIND_GET(hand_win%(1),4,xf&,yf&,lf&,hf&) ! on r‚cupŠre les coord de notre fenˆtre ~WIND_GET(hand_win%(1),11,rx&,ry&,rl&,rh&) ! on r‚cupŠre les 1eres coord de la liste des rectangles ENDSELECT ' IF win!(1)=TRUE AND aff!(1)=TRUE AND arbre%=1 ! si la fenˆtre existe et affichable control ! on prend le contr“le de la situation WHILE rl&<>0 AND rh&<>0 IF RC_INTERSECT(xf&,yf&,lf&,hf&,rx&,ry&,rl&,rh&) ! rectangles en commun ? ~OBJC_DRAW(adtree%(arbre%),fils%,1,rx&,ry&,rl&,rh&) ! on dessine selon le clipping ENDIF ~WIND_GET(hand_win%(1),12,rx&,ry&,rl&,rh&) ! la suite des rectangles SVP ! WEND uncontrol ! on rend la main au Screen manager ENDIF RETURN ' > PROCEDURE force_top(bar%) ~WIND_GET(0,10,top_win%,dummy%,dummy%,dummy%) IF top_win%<>hand_win%(bar%) AND win!(bar%) INT{m_adr%}=21 ! tiens ? j'ai remplie €a comme le Screen manager INT{m_adr%+2}=ap_id& ! je m'appelle moi-mˆme INT{m_adr%+4}=0 INT{m_adr%+6}=hand_win%(bar%) INT{m_adr%+8}=0 INT{m_adr%+10}=0 INT{m_adr%+12}=0 INT{m_adr%+14}=0 ~APPL_WRITE(ap_id&,16,m_adr%) ! … connaŒtre pour faire des merveilles en multitƒche ENDIF RETURN ' > PROCEDURE shut_down ! compatibilit‚ avec les OS modernes, ~APPL_EXIT() QUIT ! suffit de quitter comme un malpropre RETURN ! mˆme pas besoin de ferme ses fenˆtres, ni lib‚rer sa m‚moire > PROCEDURE win_moved m_8&=MAX(screenx&+1,m_8&) m_10&=MAX(screeny&+1,m_10&) ~WIND_SET(m_6&,5,m_8&,m_10&,m_12&,m_14&) IF m_6&=hand_win%(1) AND win!(1) move_win(1,m_8&,m_10&,m_12&,m_14&) ENDIF RETURN > PROCEDURE win_topped IF m_6&=hand_win%(1) AND win!(1) ~WIND_SET(hand_win%(1),10,0,0,0,0) ENDIF RETURN > PROCEDURE redraw ' control ~WIND_GET(m_6&,11,rx&,ry&,rl&,rh&) WHILE rl&<>0 AND rh&<>0 IF RC_INTERSECT(m_8&,m_10&,m_12&,m_14&,rx&,ry&,rl&,rh&) IF m_6&=hand_win%(1) AND win!(1)=TRUE ~OBJC_DRAW(adtree%(1),0,3,rx&,ry&,rl&,rh&) ENDIF ENDIF ~WIND_GET(m_6&,12,rx&,ry&,rl&,rh&) WEND uncontrol ' RETURN ' > PROCEDURE gere_interieur_fenetre SELECT OBJC_FIND(adtree%(1),0,5,mo_x&,mo_y&) CASE 41 black_white(1,41,1) delai gere_alert black_white(1,41,0) DEFAULT win(1) ENDSELECT RETURN > PROCEDURE gere_alert ~FORM_ALERT(1,CHAR{OB_SPEC(adtree%(nb_tree%),2)}) ! plus de fenˆtres RETURN ' > PROCEDURE info ~WIND_UPDATE(1) ! je bloque tout, boŒte de dialogue bloquante ~WIND_UPDATE(3) ~FORM_CENTER(adtree%(2),xd&(2),yd&(2),ld&(2),hd&(2)) SUB xd&(2),3 SUB yd&(2),3 ! j'‚largie la zone car le TOS 4.0X bave sur les c“t‚s ADD ld&(2),8 ADD hd&(2),8 ' on pr‚vient le Screen manager que je r‚serve une zone pour ma boŒte ~FORM_DIAL(0,0,0,0,0,xd&(2),yd&(2),ld&(2),hd&(2)) ' et je la dessine, bien tranquillement, le clipping=‚cran entier ~OBJC_DRAW(adtree%(2),0,3,screenx&,screeny&,screenl&,screenh&) ' e%=FORM_DO(adtree%(2),0) ! surveillance automatique du GEM de ma boŒte OB_STATE(adtree%(2),e%)=0 ! on remet l'‚tat de l'objet cliqu‚ (m‚thode … l'arrache) ' ~WIND_UPDATE(2) ! on d‚bloque tout ~WIND_UPDATE(0) ' et je pr‚vient le Screen manager qu'il faut refaire ses dessins ~FORM_DIAL(3,0,0,0,0,xd&(2),yd&(2),ld&(2),hd&(2)) RETURN ' > FUNCTION s_exist(exist_name$) exist_name$=exist_name$+c0$ LOCAL existe& IF LEN(exist_name$)=0 OR LEFT$(exist_name$)=c0$ RETURN FALSE ELSE existe&=GEMDOS(61,L:V:exist_name$,W:0) IF existe&>0 ~GEMDOS(62,W:existe&) RETURN TRUE ELSE RETURN FALSE ENDIF ENDIF ENDFUNC > FUNCTION test_cookie(cookie_name$,VAR cookie_valeur%) LOCAL read_cook%,nom_cook%,cookie% ' nom_cook%=CVL(cookie_name$) cookie%=LPEEK(&H5A0) cookie_valeur%=0 ' IF cookie%<>0 REPEAT read_cook%=LPEEK(cookie%) cookie_valeur%=LPEEK(cookie%+4) ADD cookie%,8 UNTIL read_cook%=0 OR read_cook%=nom_cook% IF read_cook%=nom_cook% RETURN TRUE ELSE RETURN FALSE ENDIF ELSE RETURN FALSE ENDIF ENDFUNC > FUNCTION window_create(cp_win_recu%) ! ouvrez-moi ' ' appel d'une fonction systŠme AES ' ya rien de plus compatible et standard ' GCONTRL(0)=100 ! opcode de la fonction: cr‚ation d'une fenˆtre GCONTRL(1)=5 ! je veux 5 paramŠtres entiers en adresse GCONTRL(2)=1 ! je veux 1 paramŠtre entier en sortie GCONTRL(3)=0 ! je veux 0 adresse% … passer en entr‚e GCONTRL(4)=0 ! ni mˆme en sortie ' GINTIN(0)=cp_win_recu% ! je remplie mes entr‚es de valeurs entiŠres GINTIN(1)=30 GINTIN(2)=30 GINTIN(3)=30 GINTIN(4)=30 ' GEMSYS ! Amen ' RETURN GINTOUT(0) ! et je r‚cupŠre l'entier que j'ai demand‚ ' ! 0=<problŠme, sinon c'est le handle de ma fenˆtre ENDFUNC > PROCEDURE v_hide_c ! ouvrez-moi aussi ' ' idem que ci-dessus, sauf que c'est un appel VDI ' il s'agit de chacer la souris ' on rapelle que HIDEM est interdit puisque c'est de la "ligne A" ' CONTRL(0)=123 CONTRL(1)=0 CONTRL(3)=0 CONTRL(6)=vdi_handle& VDISYS ' RETURN > PROCEDURE v_show_c CONTRL(0)=122 CONTRL(1)=0 CONTRL(3)=1 CONTRL(6)=vdi_handle& INTIN(0)=1 VDISYS RETURN > PROCEDURE control ~WIND_UPDATE(1) ! je prend le contr“le et je bloque tout ~WIND_UPDATE(3) ! v_hide_c RETURN > PROCEDURE uncontrol ~WIND_UPDATE(2) ~WIND_UPDATE(0) v_show_c RETURN > PROCEDURE delai ~EVNT_TIMER(75) ! petit d‚lai de 75 millisecondes RETURN

Lien du PRG