MODULE A {Superclass alfa { Unique: counter=1 Public: Value { For SuperClass { =.counter .counter++ } } Module Reset (x){ For SuperClass { .counter<=x } } } a=alfa b=alfa Print a=1, b=2, a=3, a=4, b=5 ' true true true true true \\ we have to use group(a) to get the group not the value \\ we use ( ) to get a copy z->(group(a)) Print eval(z)=6, a=7, b=8, eval(z)=9 ' true true true true z=>Reset 100 Print eval(z)=100, a=101, b=102, eval(z)=103 ' true true true true For z { .Reset 10 } Print eval(z)=10, a=11, b=12, eval(z)=13 ' true true true true } MODULE GEORGE {Binary { /9j/4AAQSkZJRgABAQEAYABgAAD/2wBDAAEBAQEBAQEBAQEBAQEBAQIBAQEBAQIB AQECAgICAgICAgIDAwQDAwMDAwICAwQDAwQEBAQEAgMFBQQEBQQEBAT/2wBDAQEB AQEBAQIBAQIEAwIDBAQEBAQEBAQEBAQEBAQEBAQEBAQEBAQEBAQEBAQEBAQEBAQE BAQEBAQEBAQEBAQEBAT/wAARCABQAFADASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEA AAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIh MUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6 Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZ mqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx 8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREA AgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAV YnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hp anN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPE xcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD+ 2GymJXCnLLzjJAOP6/410FtdEZUsM5yFAIzzgnP51zdqrfKT24xnBOOn9K2IA2VY KAMfeAyOuOfyrdSqJaLc3ioydt/vOkiutqBjkcZPzdc9K+fPjN+2D+z7+z3byj4o /ErQ9D1GOMSjw9DIdW8ROGVmU/Y4Q0gBCk7nCjpyK8N/b8/aP8R/s7fBaC6+H8LX nxU+I/iOHwH8O7eO2W+nsriaKWe6vxCQVb7NbwSsu8FBK8O7KkivzW/Z1/4J8weO V1X4pftTeKdT8T+JvHc8moS6DNKNRj05ZCW/fPLuaaaTexaRjxlcAAADxc5z55Zy YeEearNX12Sva7trr6o93JOH8VnNSTor3I7vz3/U+o9U/wCC7v7EuiamNNub/wAd 5CmWe9OgWz20EeV2sRHdNJ8wJONmQPvba+qPh5/wVO/Yd+Jdvpsnh748eHFk1G5S 2httWtL3R5kkkGQsgmiUALghnztXuRkZ8M0T/gm7+xq+h3Ont8P9NYSwtEL67t4Z L1QVwPKypEZXAAPPQcdBX5H/ALav/BKv4VfDfQr/AOJ/w38T+KZLfw5IbxfDVnLb 2yooyXZ2jRWc853H0FfMf6xZvCaqVFTlF3stU/LW/wCFvme3V4P5KcpQTfKrya6a ea/I/rj0zxDaapZ299YXcN5ZXtqtzaXdtIJba6RxlZI2BwQQQQQcHNaf9oqwI3c9 ST82c4r+bL/gmv8A8FBbzTNU8B/s3fEq8F7oN5DF4f8ABPiaZXjvdEnkP+g6fftj a6ykpCkg5V9qsBkV/Q2t0wOSTk9t2dvpj9K+0y+VHMaEaqVp2V472b/R9GfD1aSo T5VqujO0N9hQMjoMHqe3NVmvwm45+bOWPTd6fTtXO/azsI3AZ4DA4571Ue4DMSOS o5wR+dehDAxuYNpvXc4eO38vYOMkY5GcYA71fSJirY+YH5VVScDnrVtYQF3MATtJ Yj6dP51YjRBGeOp3YHJz3xXQoKcvdf3EKT5eZo/OH482fh3W/jZceJfEtxBqD/D7 w/F4c8IaLdTD7Hp014qXup3oUjHm3Aexg3YJVLEgcSMDyFv8VdPRIVS53osm1oYJ ljZMdFVc9Mdx6V84ftB6lLdftPfE2w1bWTpWm2OrwxI0k7QxBTZWrIMDJJ2up4/S uPtfHHw58KzSz3N4NTSHcnmiUEM2cZZgThSNvUcelfkPEWNnXzmtSktISt8la35H 79wXTp0sjpSw2rmrt+b3u/L8kfZt58WvEYsp5dM0XUIbOND5epF8IxPQsOpPXHY1 4N4q+KMfiG1vNB8QRiW1vke3vLa6kEiXiuhEitGR3ztwevpXj+uftreB7W2j0jU9 U0rwzokR2uwBnv7lBlCFCcrggcnr6ivKfHfxT+Ct7YJrvh74jxSX0iiQQavbPZpc BgON5B2nn+I896+XzLE03BTp1F7uru0l8r/n9x7VWvL3qLSae6X6n41/G1vFXg74 57Phhdx6Nq3hfUo9V0x3uBDJIltdS3NvIZV3LELR0U5aNsswXI8wA/3Jfsw/FW9+ NHwH+FvxQ1S0trLU/F3hG11PUrOzuBdW0N0UEdyqt1wJUk4PIxg8g1/Cl+314Qvt WsrL49/D7WpoYk1CHw94tt7KRXQxXbLbrdrtzwXMYOCSS2SDjFfvL/wRa/a58Y2f gn4V/sv+N/DEiaHbaRqNj4f8Zxzy3jw6w11far/Z9x/AkElo48nABDxFSSWwv0/C XFuGo46lDGSahVtTi1qnK6tdJaW11ufjub8P4upVrLCxTcE5taLTd211drWW+lj+ kQSLhehzxgHGPTmmO4A3YCgD+fHNUxcJhcDJCZGDgflTJZzsORjPJwMHFfuapXsz 88deXTYatyBhWxjIwQwyB3qVZkYEBhjnhSORngc1yhv1XkEnHAwM5PH/ANfmnNfh gCGwOuemOfSvFpVoJef/AAx66ovqfz9f8Fg9avfg18QPDHirQbB0PxW02UJJaWB1 PUNZ1LTLdvtFvbRghVdbSKGUljyEY5GMH8hf2Qvi5qf7Vnj6fwHp2ma3o8Wo6bcl dV1mx+yWwaByjhURm+bcQOoIPav6Uv8AgqD8Prf4gfs7jWvJtZL7wF4jg1mC8eMm 8so7tJLGQwNjIJaeAtjqsZr8Jv2T9Csfh98XofEkt3bw3f8AZ09zcz3Eu0bPMjiQ DjaBl84UA8etfjnHmGdPOoYmE2lU5ZNaWsnZrzbtf9T9d4EnXrYH6tG3LFtdb62a ej21Pz9+K2n/ABH0f4qav4S1iW9svDGg641rrN7pisNfuLdRIm60dkIU79jZYdDj I5rxrwV8Afib4z8WaR4dtviZ441oap4guLq58Qa3c3CQRWJEe23ltWdkOwKeUx8z nkBQD+nf7ad54X8M+KT4/wBHv9Cv7cSK/iDToNYiXVoUkcq0sMOSZFG5Sy9cGvOf CnjDwXpdtfXxuJ4I3hVJJLFvJvIFcbiOhOcHoB2r8uxca1HE4jA1JR9k7NSdm3F9 LtuzWqfbc+5llNRuNazUo3V7tJ3tutn5Ni/H3whofw/+FHiH4SaVrlvrNnrPhtre 4uZm+0vHdwoJoWzyeZYhkY6A19Y/sHfDTXvC3xQ+HPxR8NeI57Iaxe+GrA+A7a8a Wy1a+m+yR6peu5OyKOGOIxrbEDzJN7qVVWDfk/8AEzx5YeItV1OO2muZNGhjkNm9 4zmRnUBt7NwcqM5xzx05zXzr8ev2lfH6eBPBej/DH4ieIfCHiHw/rO1LfRtRm05t dKwJIqkqwAZWR8B8iXzWTnIDZ8MYqlis0hhox/dwmvZrW111ur2V1p367nz+aP8A syNStO7XJKMna+62fz+5H+lbHqitGpRs4AJKqMHPvSy34ZSdy4I6bgueMGv4Pf2M f+Cj/wC0V4J1P4VXum+PPFWpaL460K8l1XQdav5NW8F2eqaYyw3USWsjkKLsZlAT YVIfa3IC/wBTH7Ln7c/hf9oBpPC+tWtr4U8fwW/nw6Ut552m6/GqgySWTNhgy8lo WywX5gWAJH9XZXxNRxKVOvFxley1uunXTXXqj+e54aFSbVJ7Xvf1+5+Wp+gpvYVz +9XbjgFgAx9Af89KiN6oBCsjDPZscZ7V+C3jf9uX9rPwSunS23w+0jxVFcrKZZLP wzfypZ+WEKeYYpyPmDN3H3DXj2o/8Fb/AI8aH5x8UfCrw3pUcDBLo3DajYz2xLbO UM+7OfT3r5rL+IMHmGCjmGGp1HSkm07LVLRu176H2OOyPEZbXlhsZUhGpG11zd1f t2aP3d/aE8OL47+DPxI8LC4trSfVfCd39jnvHSO0huYozPbvI7YCqJI0yxPAya/i D+O/xa8SeEraz1Tw7csl7qk0ukWuspfKulaRI0gLNcMWCHIXavOCTx2r6L/ba/4K IfGf40aDqen+JvFX/CN/D5LXzH8DeGppLLSL4RqCW1CUv514crkJI/lZYYjyM1+S HwS/aW0y9bU/B/jC2srqOfxD/bPh4XMKxQR24mDsGzwHXazYHJDcdMV+f8f4upmG GpVcJRcoQd3K9m02tl1tZPc9jgnO6WBzCrhvaWvZeV15+fTQ868d694h1jxFb+LN d+Iuk6lqtmUkEGnPc31tqjIzNmQAbQMiPqMZ6Zxk+v8Aw7+JPxZ8Y+K9LnmP2Twj PFJZ31zcWq21tc4jfyxztLEkYDABcvXtPj74dfDW+17SLyDxKLGLWbuK6udHtbWE STRyBdiK5GYwWD9QclSDXn/xO8aeC/Bnh5bDw3dbtLhYQXsBXZdmVlkEahycgK65 Jx8pIHbNfl2Lx1PFwpYbCUFKrPTr7qe7069dWft2KxGFjhViac5K6vK9mnaye+nT okjzX4leMorZ9TiTVEgFlMIzAJy8lt52FJPUEE5B/wB2vmvwJYN8QviLbnU7iU+H vDkUnjHxFcYEiizsCj7WJ6LLKYY+cY8zivJ/GHje71m5vra2l8u0nui52rtkdRkI CQcd8n3Fe16DDefDf4D6j4ilXyvFPxvuToPh+MoGvYtDsmeCaVV+9tu7l5EXj/mF secjH6dwfwqstiq9VXkkm/RW3b7n4txRxOsVCeGw+1kr6Wd99ux9Zfsv+IJrPwd4 A0uZVibUdb1jUdPdXBRIIiHBAJB4LuOBwcfj+h3w++IvinQ/EOlePfDWr3Gl3vhb WIrzSLiIbSjxSD5xwcq2MMBjcrEZwa/PPwDpEOk+PvBvgOGYK/hD4Tq17JbgBobi 9ltYpGzj7xWCV8n/AJ6V9p2etaDp+nSWlndRTJB+7eKOUPMxGAdy9s/Svp5qcXJO 0YvXrq3vbtZ6H49WqqVV1qT5W22u/k/1P2R/a3/bL1z4D6zpvgD4deItEbUtVs/t Pi7Q5NMh1GOzdXjfTPtV0VLW7MvnlY1YMwIYjG3P48+O/H+r/EjWb7XPHl1ca3rV 7vF2b+d4zCjhVSIMoTbAqoFWNABgLgCvUv2nfhlrXwe+KPiPSdbvL/UrLxHeS61p mtai8l7Jqcc8ryx3LSfM0kwdSr7udyHnGM/IviqfVbKwnv7XSrnUdSjtiq2sC+Sy svbDYORjGRjAxx83Hy2UKthsrw+Dpz5lGN04rR3fN2ber/zPsuOc7xua55iHVpum lJLlelmkld23bt+R+dHx/wDiNr9xqmteGbkPDbQXTGx81xcS3cayBUWRiSd6AgEE ZYqG718lXyNaXCoWP2uMiS4dZASkh52gg4+X2759K+kvjgBqWsyalqFrPbXV1APP sGlCfZ5UTaXIIznheR8rbfevl91KsQ3J9c5zXv4KVKtS2fmn/wAN+FjyMtl+75/t rdrqe6aV8VfiHr1ta6Xazrf6npljHa29zcTKtz5MLMyhVYgFgWHPX0rm9e074h+I Lgf20bqdpTv8uecBBnJzsDHr1zjkmvO9O1C60q8hvbOZobiFtySLwV7Ee49jXaxf E7xPDOLiOW1WYMGDraRqSQCBnA561wTyv6riHWy2hTV+rVmn176H3WDzTD4jB/Vc 3xNSyeiTureZ0/hn4Z6dZ6zoM3xM1lvCXha51SODVNRS2lvLmKJgzYjjRSxZtuMg EKCSemK9y1zxBpnxX/aI8JadpEdvB8PfCKW9v4U07gx22k6Rb7rFCP70qwxSuuM+ ZdS5Ar5G17xVrviWSN9X1Ge88qR5YlkI8qFnCK21ccZEaDH+zXtnwL8DW11LL418 UTSaN4at5W0qx1ieZLW0F0yjLB2VgWj3KVBUqW9xXsYfEYjDYCVPEWc27yte3kl5 Lc+T4grZfByrYRONKMbK+rbate3dvbU+itL8SRaXrPjDx1c38i+I/GviCTTfC+kw RSXd9qFpp5a1WO3gXLEtIsgyPl+Xvzj1Xwp4W1TU79JfG8d9c3epQq0Hgey1c2sF oZAG+0ao8DAu+GCC2DFFAJclm2pT8M6ZpekyxXHgg2+saxqumxaI/i+5VPKtbZdz SpYqFDJ5jSNJIw5dm9MV6npt14W+G+j3GqaxqtlFJFGZtV1m6lCqwdssI2JJG5iQ ABuc/dDHrlRlzyUqes1o3urp6q3rbU+BlUqPllQi7SSV2ldWSSsvzP/Z } As A Gradient 13,5 ImgRenderX=scale.x div 2 For ImgRenderX=ImgRenderX to ImgRenderX/4 STEP 150 TopMargin=(scale.y-(ImgRenderX)*image.y(A)/image.x(A)) div 2 LeftMargin=(scale.x-ImgRenderX) div 2 move LeftMargin, TopMargin Image A, ImgRenderX Next cursor 12, height-2 Writer Escape Off while mouse=0 and inkey$="" refresh End While Escape On cls if module(infobasic) then infobasic } MODULE B {\\ m is an auto array (a tuple) \\ z is an iterator of m m=(1,2) : Print valid(m^)=false ' bug return valid(m^)=true z=each(m): Print Valid(z^)=true } MODULE C {dim a(), b() a()=(1,2,3) b()=(3,2,1) for i=0 to 2 print max(a(i), b(i)), max(b(i), a(i)) print min(a(i),b(i)), min(b(i), a(i)) print compare(a(i), b(i)), a(i), b(i) next i dim a() a()=(1,2,3) for i=0 to 2 print max(a(2-i), a(i)), max(a(2-i), a(i)) print min(a(2-i),a(i)), min(a(2-i), a(i)) print compare(a(i), a(2-i)), a(2-i), a(i) next i } MODULE B1 {Module ViewStatic { static Img1, tempo=1, gx=3, gy=5 ? tempo, gx, gy tempo++ gx++ gy++ } clear for i=1 to 10 ViewStatic next clear } MODULE BB {if row"" Τότε Έξοδος \\ θα μπουν ανάποδα, το τελευταίο πρώτο. Βάλε "CM", "MD", "Q","CD", "MD","W", "XC", "DL", "E","XL", "X","R", "IX","V","T", "IV","I","Y" διπλό_λατινικό=[] \\ θα μπουν με το τελευταίο να είναι τελευταίο. Σειρά "M", 1000, "Q",900,"D", 500,"W", 400,"C",100,"E",90, "L",50,"R", 40,"X", 10, "T", 9, "V", 5, "Y", 4, "I",1 απλό_λατινικό=[] σύνολο=0 μια_τιμή=0 μετρητής=0 Σωρός διπλό_λατινικό { Αν κενό Τότε Έξοδος Διάβασε απ$, μη_έγγυροι_χαρακτήρες$,χαρακτ$ ι=Θέση(λατ$,χαρακτ$) Αν ι >0 Τότε προσωρινή_τιμή$=Μεσ$(λατ$,ι+2) λ=Μήκος(προσωρινή_τιμή$) Αν λ>0 Τότε Αν Μήκος(Φίλτρο$(προσωρινή_τιμή$, μη_έγγυροι_χαρακτήρες$))<>λ Τότε λατ$="A": Έξοδος Αν Θέση(λατ$,Μεσ$(λατ$,ι,1))<ι Τότε λατ$="A": Έξοδος insert ι, 2 λατ$=απ$ ' 2 λέμε αλλα δίνουμε 1 χαρακτήρα και ο μεταφραστής θα βάλει ένα διάστημα Τέλος Αν Κυκλικά } λατ$=Φίλτρο$(λατ$," ") Σωρός απλό_λατινικό { Αν κενό Τότε Έξοδος Διάβασε χαρακτ$, μια_τιμή μετρητής=0 Ενώ Αρισ$(λατ$,1)=χαρακτ$ Παρεμβολή 1, 1 λατ$="" μετρητής++ σύνολο+=μια_τιμή Τέλος Ενώ Αν μετρητής>3 Τότε έξοδος Κυκλικά } Αν Μήκος(λατ$)>0 ή μετρητής>3 Αλλιώς =Γραφή$(σύνολο,1033) Τέλος Αν } Σειρά "MMMCMXCIX", "LXXIIX", "MMXVII", "LXXIX", "CXCIX","MCMXCIX","MMMDCCCLXXXVIII" Σειρά "CMXI","M","MCDXLIV","CCCC","IXV", "XLIXL","LXXIIX","IVM" Σειρά "XXXIX", "XXXX", "XIXX","IVI", "XLIX","XCIX","XCIV","XLVIII" Επιστροφή } Λατινικοί_Αριθμοί } MODULE DD {Print "A structure in a Class" class beta { structure alfa1 { a as long*4 b as long*4 } structure alfa { a as long*4 b as long*4 c as alfa1*3 } buffer delta as alfa*3 } beta=beta() Print "Offset b in structure alfa" Print beta.alfa("b") list } MODULE DD1 {local group alfa { x=10, y%=50, z$="anything here" dim M(4)=10 event alfa {read b} document a$="100" class allo { q=4 } Group M { k=10 } function delta { } module kappa { } } testMe() Print "After the call" List ! Modules ? End Sub testMe() Print "Create a second alfa group, hidding the old one" local group alfa { x=10, y%=50,z$="anything here" dim M(4)=10 event alfa {read b} document a$="100" class allo { q=4 } Group M { k=10 } function delta { } module kappa { } } List ! Modules ? End Sub } MODULE DD2 {Print "Make some constant lambda functions" const b=lambda->100 const b%=lambda->100 const b$=lambda$->"hello" Print b%() Print b$() Try ok { b=lambda->500 } if Error or Not ok Then Print Error$ Print b() } MODULE DD3 {cursor 0,height-1 Pen 11 {Print "When report stop press space or mouse button"} Report "Reassign a lambda function in a Group - static link group, we use a unique name of group as local identifier" Report { group alfa { x=100 b=lambda->{ =.x .x++ } } } \\ this is in a global module A group alfa { x=100 b=lambda->{ =.x .x++ } } \\ get a copy to alfa Report { We make a beta as a copy of alfa } beta=alfa Print "alfa.b()=";alfa.b() Print "beta.b()=";beta.b() Report { Try to change function with a fake one function alfa.b { =500 } } function alfa.b { =500 } Modules ? Print "alfa.b()=";alfa.b() Report { References for functions are strings with code. We get {CALL EXTERN 3}A.ALFA, but is not the actual hard link. The actual code is in lambda object. 3 is the actual "slot" or index in a var(), an array of variants inside M2000 code where all the variables and this object exist. } pen 15 {Report 2, &alfa.b()} Report { We can make a link of alfa.b() to f() (only for new identifiers). The reference has the same weak reference to the name of group. So we can make a reference if the group has a name (is not keep it by a pointer, or exist in an array or other object like stacks and inventories) } Link alfa.b() to f() Report { This is the function f() code (a reference to a function is actual the code of the function in a string in a block {}). We see two things. One is a line 11001edit which used when an error happen to display the line of the code, and the other is the weak reference of the actual group, which copied by the link statement (a link statement is actual two statements a Push and a Read). We can't assign a second reference. } Pen 15 {Report 2, &f()} Report { This function can be changed because has no "hard link" with lambda All functions except final in groups can be changed: function f { =500 } } function f { =500 } Print "f()=";f() Print "alfa.b()=";alfa.b() Print "beta.b()=";beta.b() \\ we can test pointers \\ there is two type of pointers \\ 1. pointers to float groups (holded in containers or by pointers) \\ 2. pointer to named groups (using a weak reference) \\ this type has no use when referenced group get out of scope \\ but as all pointers can change value later \\ pointers can be null, using p->0 but they hold just an empty group \\ so never a pointer in M2000 has a real null value, but an "empty" one. Report { Reassign a lambda function in a float group -group handled by pointer(s) - no static linked We use p->pointer((beta)), is the same as p->(beta) Parenthesis used to make the beta a copy as a float group, so we get the pointer to that float group Without Parentesis the pointer is a weak reference to beta, so if we pass the pointer as a return value the beta group deleted and the weak reference be invalid. Using the float group, we can move it (like a float object) any where. The float group destroyed when no pointer points to it. So the copy we get has the last state of the object, where beta.x is 102. We can use -> in place of = for a return value from a function, but we have to use (name_of_group) to return a float group not a reference. } \\ p->(beta) is the same as this: p=pointer((beta)) ' a copy of beta Print "p=>b()=";p=>b(),"p=>b()="; p=>b() Print "beta.b()=";beta.b() \\ p->beta is same as this Report { Now we change p to point to beta, using p=pointer(beta) same as p->beta (we use pointer() to pass as an argument, where we can't use ->) } p=pointer(beta) ' as reference to beta Print "p=>b()=";p=>b(),"p=>b()="; p=>b() Print "beta.b()=";beta.b() } MODULE DD4 {Report { This example show how to use closures in lambda functions } n=lambda ->500 a=lambda n (x)->{ if x<=0 then=0 : exit =lambda(x-1)+x+n() } Print a(3)=1506 Print a(10)=5055 n=lambda->100 \\ closures are copies, and are like globals for lambda Print a(3)=1506 \\ closures can be change only from inside \\ if they are value types (lambda is a value type) m=lambda->100 a=lambda n, m (x)->{ if x>5 then n=lambda ->500 if x<=0 then=0 : n=m : exit =lambda(x-1)+x+n() } Print a(3)=306 Print a(10)=1055 \\ touple is an array, can have zero items (,) \\ or one ore more, and it is a reference type z=(m,) Print Function("m")=100 Link z to Z() Print Z(0)()=100 a=lambda z (x) -> { if x<=0 then=0 : exit link z to z() =lambda(x-1)+x+z(0)() } \\ now we change value in z(0), which is the z Print a(10)=1055 z(0)=lambda->300 \\ so now lambda change because hold a closure to a reference Print a(10)=3055 Print eval(z)(0)()=300 \\ without using link we can get the first element in 0 posiiton, and ask for function \\ this function has a life for the moment of call \\ interpreter just open the lambda object, invoke, and close again. a=lambda z (x) -> { if x<=0 then=0 : exit =lambda(x-1)+x+Eval(z)(0)() } Print a(10)=3055 } MODULE DD5 {class a { counter as long } b=lambda k=pointer(a()) (x)-> { k=>counter+=x \\ we can return pointers from groups (if they are float type) ->k } m=b(30) Print m=>counter=30 \\ get a pointer and convert it to a named group, and then return a float group (as is, without pointer) def copy(x as group)=x group k=b(300) z=b(300) Print z=>counter=630 Print m=>counter=630 Print z is m ' false z->b(300) Print z is m 'true Print z=>counter=930 Print k.counter=330 ' old value } MODULE DD6 {group beta { x$="1000mm" m=100 } \\ beta copied here inventory alfa=1:=(list:=1,2,300:=(1,2,3,3,5,beta), 500:="ok") dim g() \\ beta copied here g()=(100,beta,(1, (list:=1:=beta,2,"z":=(1,200,3,alfa), "s":="string"), "Hello there"), 500@, "ok") g(1).m*=100 Print g(1).m=10000 link g() to g$() Print type$(g(2), 1)="Inventory" Print type$(g(2), 1!)="List" ' show type of inventory (list or queue) Print type$(g(2), 2)="String", g(2)#val$(2)="Hello there" Print g$(2)(2)="Hello there" ' using g$() a reference to g() Print g$(2)(1)("s")="string" Print g$(2)(1)("z")(3)(1)(500)="ok" \\ new this also Print g(2)(1)("z")(3)(1)(300)(5).m=100 ' multiple object opening until a group object \\ new this also. we can get a pointer from inner group n->g(2)(1)("z")(3)(1)(300)(5) Print n=>m=100 n=>m++ ' increment one Print g(2)(1)("z")(3)(1)(300)(5).m=101 Print g(2)(1)("z")(3)(1)(300)(5).x$="1000mm" n=>x$="2000mm" Print g(2)(1)("z")(3)(1)(300)(5).x$="2000mm" m=g() ' we get a pointer to array ' these are not the same as the group's pointers \\ stacks, inventories and arrays (not those we make with Dim) are pointers \\ we can use IS operator to check two of them if show same object z=list:=100, 150:=m, 200 Print z(150)(2)(1)("z")(3)(1)(300)(5).m=101 \\ using g() we pass a copy \\ but anything which is a pointer (like a list, or a pointer to array) only pointer copied \\ groups may have or may haven't pointers. Those with no pointers copied when we get an array copy. \\ Only arrays with names with parenthesis copied. So here we get a copy of g(). z=list:=100, 150:=g(), 200 g(1).m+=100 Print g(1).m=10100 Print z(150)(2)(1)("z")(3)(1)(300)(5).m=101 ' group has a pointer/ also list is the same Print z(150)(1).m=10000 ' group copied n=>m++ Print z(150)(2)(1)("z")(3)(1)(300)(5).m=102 Print g(2)(1)("z")(3)(1)(300)(5).m=102 } MODULE DD7 {module Checkit { Stack New { Data "foo://example.com:8042/over/there?name=ferret#nose", "urn:example:animal:ferret:nose" Data "jdbc:mysql://test_user:ouupppssss@localhost:3306/sakila?profileSQL=true", "ftp://ftp.is.co.za/rfc/rfc1808.txt" Data "http://www.ietf.org/rfc/rfc2396.txt#header1", "ldap://[2001:db8::7]/c=GB?objectClass=one&objectClass=two" Data "mailto:John.Doe@example.com", "news:comp.infosystems.www.servers.unix", "tel:+1-816-555-1212" Data "telnet://192.0.2.16:80/", "urn:oasis:names:specification:docbook:dtd:xml:4.1.2", "ssh://alice@example.com" Data "https://bob:pass@example.com/place", "http://example.com/?a=1&b=2+2&c=3&c=4&d=%65%6e%63%6F%64%65%64" a=Array([]) } function prechar$(a$, b$) { if a$<>"" then {=quote$(b$+a$)} else ={""} } z=each(a) document s$="["+{ } While z { a$=array$(z) s1$={ "uri": }+quote$(a$)+{, "authority": }+ quote$(string$(a$ as URLAuthority))+{, "userInfo": }+ quote$(string$(a$ as URLUserInfo))+{, "scheme": }+quote$(string$(a$ as URLScheme))+{, "hostname": }+quote$(string$(a$ as UrlHost))+{, "Port": }+quote$(string$(a$ as UrlPort))+{, "pathname": }+quote$(string$(a$ as UrlPath))+{, "search": }+prechar$(string$(a$ as URLpart 6),"?")+{, "hash": }+prechar$(string$(a$ as UrlFragment),"#")+{ } s$=" {"+{ }+s1$+" }" \\ z^ is the iteraror's counter (z is an iterator of a, a touple - array in M2000) if z^10,ΕύροςΤιμώνΧ) κλΧ=1 Αν μέρη>15 τότε κλΧ=ΕύροςΤιμώνΧ δια 15 : μέρη=Στρογγ(ΕύροςΤιμώνΧ/κλχ+.5,0) Αλλιώς κλΧ=ΕύροςΤιμώνΧ / μέρη: Τέλος Αν ΖουμΧ=1.2 δχ=χ.σημεία/ΖουμΧ/(μέρη+δεκ(κλΧ)) δψ=υ.σημεία/1.5/10 βαθμόςΥ=δψ*10 ΒάσηΧ=(χ.σημεία-χ.σημεία/ΖουμΧ)/2 ΒάσηΥ=(υ.σημεία+βαθμόςΥ)/2 Θέση ΒάσηΧ, ΒάσηΥ Χάραξε 0,-βαθμόςΥ Βήμα 0, βαθμόςΥ Βήμα χ.σημεία/ΖουμΧ, 0 Χάραξε -χ.σημεία/ΖουμΧ, 0 κανε αα(μέγιστο, κάτω=0, Ν=50)=ΑΝ(μέγιστο=0->0, Ν*(((μέγιστο+2^Λογ(Απολ(μέγιστο)) ) διά Ν)-(μέγιστο>0)-κάτω)) \\ άλαξε το 100 με το 50 ή το 500 μέγιστο=αα(μέγιστο,,100) ελάχιστο=αα(ελάχιστο,1,100) κλψ=-βαθμόςΥ/(μέγιστο-ελάχιστο) \\Φτιάχνουμε οριζόντιους γραμμές με τελίτσες ανά δχ \\ Το ύψος.σημείου είναι ο αριθμός σε twips του ύψους ενός σημείου στο μέσο που γράφουμε \\ αν στην οθόνη έχουμε 96dpi, τότε έχουμε σε 1 ίντσα, 1440 twips, ή 96 σημεία, \\ άρα κάθε σημείο θα έχει 1440/96 = 15 twips \\ και πράγματι τόσο είναι το Ύψος.Σημείου σε 96dpi. Όμως μπορεί να έχουμε οθόνη με διαφορετικά dpi. \\ Αν θέλουμε να μετρήσουμε αποστάσεις βάσει σημείων πρέπει να πολλαπλασιάζουμε με τον αριθμό \\ των twips ανά σημείο. Ορισμένες φορές μπορεί να μην έχουμε τετράγωνο σημείο, δηλαδή να διαφέρουν \\ τα Ύψος.Σημείου με Πλάτος.Σημείου. Για το λόγο αυτό χρησιμοποιούμε και τα δύο. κ=1 τ=ΒάσηΤιμώνΧ δτ=κλΧ αν δτ=0 τότε δτ=1 Πενα 15 { Για ι=ΒάσηΧ έως ΒάσηΧ+δχ*μέρη Ανά δχ Θέση ι, ΒάσηΥ Βήμα 0, Ύψος.Σημείου*(10+ΑπόσταστηΑριθμών) Επιγραφή μορφή$("{0}",τ), "courier new", μέγεθος_12pt, γωνία, κέντρο Βήμα 0, -Ύψος.Σημείου*ΑπόσταστηΑριθμών Αν ι>ΒάσηΧ Τότε Πάχος 1, γραμμή_με_τελίτσες { Χάραξε 0, -βαθμόςΥ-Ύψος.Σημείου*10,7} κ++ : τ+=δτ Επόμενο } \\ φτιάχνουμε κάθετες γραμμές ανά δψ ΜισόΎψοςΚειμένου=Μέγεθος.Υ("1","courier new", μέγεθος_12pt)/2 ΣτόχοςΥ=ΒάσηΥ-δψ*10 Πένα 15 { Για ι=ΒάσηΥ έως ΣτόχοςΥ Ανά δψ Θέση ΒάσηΧ, ι Βήμα -Πλάτος.σημείου*10 Αν ι<ΒάσηΥ Τότε Πάχος 1, γραμμή_με_τελίτσες { Χάραξε χ.σημεία/ΖουμΧ+Πλάτος.σημείου*10,,7} Θέση ΒάσηΧ-Πλάτος.Σημείου*(4+ΑπόσταστηΑριθμών), ι+ΜισόΎψοςΚειμένου Επιγραφή μορφή$("{0}",(ι-ΒάσηΥ)/κλΨ+ελάχιστο), "courier new", μέγεθος_12pt, γωνία, αριστερά Επόμενο } \\ Τώρα χαράζουμε μια γραμμή που θα περάσει από όλα τα σημεία \\ με την Χάραξε Έως δίνουμε απόλυτες συντεταγμένες (χωρίς το Έως δίνουμε σχετικές) δχ/=κλΧ ΒάσηΥ-=ελάχιστο*κλψ Θέση ΒάσηΧ, πίνακας(ψ,0)*κλΨ+ΒάσηΥ ΒάσηΧ-=Α(0,0)*δχ Για ι=0 έως Μ Πάχος 2 { Χάραξε έως Α(ι,0)*δΧ+ΒάσηΧ, Α(ι, 1)*κλΨ+ΒάσηΥ, μπλε } Επόμενο \\ Δεύτερο πέρασμα για επιγραφές και σημάδια Για ι=0 έως Μ Θέση Α(ι,0)*δΧ+ΒάσηΧ, Α(ι, 1)*κλΨ+ΒάσηΥ Βήμα -Πλάτος.σημείου*5, -Ύψος.Σημείου*5 \\ τετράγωνο γύρω από το σημείο Πένα 12 { Χάραξε Πλάτος.σημείου*10 Χάραξε 0,Ύψος.Σημείου*10 Χάραξε -150 Χάραξε 0,-Ύψος.Σημείου*10 } Πένα 13 { Βήμα Πλάτος.σημείου*13, -Ύψος.Σημείου*13 Επιγραφή μορφή$("{0}|{1}", Α(ι,0), Α(ι,1) ), "courier bold", μέγεθος_11pt, γωνία, δεξιά } Επόμενο Ομαλά Όχι } 'Ζεύγη_Τιμών 'εξοδος Σχέδιο Κλίμαξ.Χ, Κλίμαξ.Υ { Ζεύγη_Τιμών } ως Α Οθόνη,0 Θέση 0,0 Εικόνα Α Πρόχειρο Α } MODULE DD9 {Report {Execute a Clear statement to erase static variables from console. Static variables reduce a bit the speed of interpreter. Except for static varibales in threads, they erased when a thread erased} a=10 Module Checkit { if random(10)=1 then Clear ' erase all statics and variables from this level Module Checkit { flush module Checkit { static k=(Queue:=1,2) Try { Read ? k as queue } Print type$(k) Print k } group alfa { x=10 } z->(alfa) Checkit Checkit z Checkit (Queue:=1,2,3,1,2,3) Checkit (List:=1,2,3) } Checkit } Checkit Print a ' a exist always keyboard "Clear", 13 } MODULE F1 {Report { OOP part 1 We make a group alfa as named group in this module, with a private x variable, and two modules (as methods) We check that alfa.x not exist using valid(alfa.x) } Group alfa { private: x=10 public: \\ we can use Print as module name Module Print { Print .x } Module IncX { .x++ } } alfa.print ' print 10 Print valid(alfa.x)=false alfa.incX alfa.print ' print 11 } MODULE F2 {module checkit { Report{ OOP part2 We make a class b1 which is a function which return a float group (nameless), but not a pointer to a group We make b as pointer of a float group (which made by b1() function) Just for the example we call beta(), a subroutine, which expect a z idenifier whch not exist So we catch this in a Try {} structure Now we make Z as pointer of a new float group using z->b1() We call sub alfa() using a local b as a predefined pointer to a float group b1(). If we didin't pass a group or we pass ?, we use b as the predefined If we have something else in stack we get error, so before that type of call we have to know what we have in stack or we can use ? } flush ' we use alfa() with an optional parameter. if stack has wrong type then we get error rem push 1 \\ this raise eror in alfa() def long counter=0 class b1 { x=10 } \\ b is a pointer to a new group from b1() b->b1() Try { beta() } Print Error$ ' z not found in scope, we can't use it as pointer \\ z is a pointer to a new group from b1() z->b1() \\ now z exist rem { alfa(?) ' use these if you use the Push 1 (see above) beta(?) } alfa() ' 11 - use of internal pointer to group beta() ' 11 Print b=>x=10 ' true alfa(z) ' 12 alfa(z) '13 beta() ' 14 alfa() ' 11 - use of internal pointer to group Print b=>x=10 ' true alfa(b) '11 alfa(b) '12 Print b=>x=12 ' true Print z=>x=14 beta() ' 15 Print z=>x=15 Print counter Rem Flush ' if you use the Push 1 Sub alfa() \\ we make a local variable b \\ we assign a fresh group \\ then we read optional a pointer local b : b->b1() : Read ? b as pointer \\ now we make a second local variable \\ we assign a pointer local z : z->b beta() End Sub Sub beta() \\ increment member x z=>x++ Print z=>x \\ subs have same scope as the module from where called counter++ End Sub } Checkit } MODULE F3 {Module Checkit { group alfa { x=10 } b->alfa checkme(b) Print b=>x=10 Print alfa.x=10 checkme2(b) Print b=>x=11 Print alfa.x=11 checkme3(&b) Print b=>x=12 Print alfa.x=12 \\ sub is like End if execution find it sub checkme(a as group) print type$(a) a.x++ Print a.x End sub sub checkme2(a as pointer) print type$(a) a=>x++ Print a=>x End sub sub checkme3(&a as pointer) print type$(a) a=>x++ Print a=>x End sub } Checkit } MODULE F4 {\\ gosub call subs (subs with () or plain subs) \\here we call a plain sub which is like we place the lines between label and return in the code where we call it gosub modules Report { This is a definition for alfa group with one public variable x group alfa { x=10 } } group alfa { x=10 } Report { we make b as pointer to alfa (is a simple reference - is a pointer to a static object) static object means named object, which exist until the get out of scope We have three modules and we call them passing the pointer b In each module we increase x value For first module we pass the b and read it as a group. So we get a new group as a copy For second module we pass the b and read it as pointer so we get the change after the call (this is the default if a in module is a new variable) For third module we pass the pointer by reference s &b, so we get the change after the call } b->alfa checkme b Print b=>x=10 Print alfa.x=10 checkme2 b Print b=>x=11 Print alfa.x=11 checkme3 &b Print b=>x=12 Print alfa.x=12 End modules: module checkme { Read a as group print type$(a) a.x++ Print a.x } module checkme2 { Read a as pointer print type$(a) a=>x++ Print a=>x } Module checkme3 { Read &a as pointer print type$(a) a=>x++ Print a=>x } Return } MODULE F5 {report { Same as F4 but now we use modules not subs A module has own scope A sub has the scope from where caled } flush '' emprty the stack gosub modules group alfa { x=10 } b->alfa \\ also here we can call like checkme ? where ? means get the default value \\ but we have to provide the default value before the actual read \\ the last moduleget a group pointer by reference so we can't provide a default value checkme checkme b Print b=>x=10 Print alfa.x=10 checkme2 checkme2 b Print b=>x=11 Print alfa.x=11 checkme3 &b Print b=>x=12 Print alfa.x=12 End modules: module checkme { group a { x=100 } Read ? a as group print type$(a) a.x++ Print a.x } module checkme2 { group a1 { x=100 } a->a1 Read ? a as pointer print type$(a) a=>x++ Print a=>x } Module checkme3 { Read &a as pointer print type$(a) a=>x++ Print a=>x } Return } MODULE F6 {\\ using static variables \\ a class function is a global one \\ from the definition point until the function get out of scope \\ here the scope is the checkme and for gloabals the checkit module Module CheckMe { Class alfa { x=1000 } Global Enum aaa {a,b,c,d} \\ use Clear to clear static from level of modules like Checkit Rem : Clear Module Checkit { \\ we can use stacks, arrays, inventories and pointers to groups \\ enumerators \\ for stacks static z=(stack:=1,2), m=(1,2,3,4), k->alfa() static b as aaa=a, cc=(List:="a":=100,"b":=500,"c":=200) read ? z Print k=>x k=>x++ Print z Stack z { if isnum then print number } Print m m++ Return cc, "a":=cc("a")+1 If Exist(cc,"a") Then Print Eval(cc) } flush ' empty stack Checkit Checkit Checkit (stack:=5,6,7) Checkit Checkit } CheckMe Clear ' clear all static variables } MODULE F7 {Report "Using advapi32.SystemFunction036 as external function to make random bytes in a buffer" Module checkit { Declare random1 lib "advapi32.SystemFunction036" {long lpbuffer, long length} Buffer Clear Alfa as long*2 Print Eval(Alfa,0) Print Eval(Alfa,1) call void random1(alfa(0), 8) Print Eval(Alfa,0) Print Eval(Alfa,1) } checkit } MODULE F8 {Report { Another example using advapi32.dll to declare three external functions We use Constant identifiers at a global level. Also the Global scope end when this module exit } Declare Global CryptAcquireContext Lib "advapi32.CryptAcquireContextW" {Long &hProv, pszContainer$,pszProvider$, long dwProvType, long dwFlags} Declare Global CryptReleaseContext Lib "advapi32.CryptReleaseContext" {Long hProv, Long dwFlags} Declare Global CryptGenRandom Lib"advapi32.CryptGenRandom" {Long hProv, Long dwLen, Long &ByRef} Global Const PROV_RSA_FULL As Long = 1 Global Const VERIFY_CONTEXT As Long = 0xF0000000& \\ a call to a function can be done like a procedure call (calling a module) \\ we have to drop the return value, because any value except zero raise an error \\ we use the clause Void to drop the value \\ In CryptGenRandom() we pass a Long which is a pointer to a Long variable \\ So we say to declaration Long &Byref (then name can be anything, but not a string identifier, we wand number) \\ So when we call the CryptGenRandom() we pass the &Rand where Rand is long variable (it is a variant of type LONG inside) Function Random2 { long Rand=0, hProv=0 Call void CryptAcquireContext(&hProv, "", "", PROV_RSA_FULL, VERIFY_CONTEXT) Call Void CryptGenRandom(hProv, 4&, &Rand) Call Void CryptReleaseContext(hProv, 0&) =Rand } m= Random2() mUnsigned=uint(m) ' uint() return Long Long if m is Long (Version 12) Print m Print mUnsigned Print hex$(mUnsigned, 4) Print sint(mUnsigned)=m ' can use long long input to get lower 32bits. Print m=eval("0x"+hex$(mUnsigned, 4)+"&") ' using & at the end we get the signed long 32 bit Print type$(mUnsigned) m1=sint(mUnsigned) Print type$(m1) m2=binary.and(m1, 0xFF00FF00) Print type$(m2) k=0xFF01FF02 Print type$(k) hex k k1=Binary.Shift(k,-8) Print type$(k1) hex k, k1 k2=Binary.Rotate(k,4) Print type$(k2) hex k, k2 \\ binary.add() make the addition of two 32bit numbers and a Mod 2^32, \\ so always we cut the overflow bit \\ The type internal is Currency, not a long, but it used in this functions like it is a 32bit value k3=binary.add(0xFF123456,0xF1234567,0xFFFFFFFF) Print type$(k3) hex K3 Function Random3 { Long Long Rand=0 Long hProv=0 Call void CryptAcquireContext(&hProv, "", "", PROV_RSA_FULL, VERIFY_CONTEXT) Call Void CryptGenRandom(hProv, 8&, &Rand) Call Void CryptReleaseContext(hProv, 0&) =Rand } Print "Long Long (Random3)" Hex Random3() } MODULE URL {Report {See also DD7 module which decoding for URI using internal functions Here we see the decoding using M2000 code (slow) } Module checkit { document doc$ any=lambda (z$)->{=lambda z$ (a$)->instr(z$,a$)>0} one=lambda (z$)->{=lambda z$ (a$)->z$=a$} number$="0123456789" series=Lambda -> { func=Array([]) =lambda func (&line$, &res$)->{ if line$="" then exit k=each(func) def p=0,ok as boolean while k { ok=false : p++ : f=array(k) if not f(mid$(line$,p,1)) then exit ok=true } if ok then res$=left$(line$, p) : line$=mid$(line$, p+1) =ok } } is_any=lambda series, any (c$) ->series(any(c$)) is_one=lambda series, one (c$) ->series(one(c$)) Is_Alpha=series(lambda (a$)-> a$ ~ "[a-zA-Z]") Is_digit=series(any(number$)) Is_hex=any(number$+"abcdefABCDEF") optionals=Lambda -> { func=Array([]) =lambda func (&line$, &res$)->{ k=each(func) def ok as boolean while k { f=array(k) if f(&line$,&res$) then ok=true : exit } =ok } } repeated=Lambda (func)-> { =lambda func (&line$, &res$)->{ def ok as boolean, a$ res$="" do { sec=len(line$) if not func(&line$,&a$) then exit res$+=a$ ok=true } until line$="" or sec=len(line$) =ok } } oneAndoptional=lambda (func1, func2) -> { =lambda func1, func2 (&line$, &res$)->{ def ok as boolean, a$ res$="" if not func1(&line$,&res$) then exit if func2(&line$,&a$) then res$+=a$ =True } } many=Lambda -> { func=Array([]) =lambda func (&line$, &res$)->{ k=each(func) def p=0,ok as boolean, acc$ oldline$=line$ while k { ok=false res$="" if line$="" then exit f=array(k) if not f(&line$,&res$) then exit acc$+=res$ ok=true } if not ok then {line$=oldline$} else res$=acc$ =ok } } is_safe=series(any("$-_@.&")) Is_extra=series(any("!*'(),"+chr$(34))) Is_Escape=series(any("%"), is_hex, is_hex) \\Is_reserved=series(any("=;/#?: ")) is_xalpha=optionals(Is_Alpha, is_digit, is_safe, is_extra, is_escape) is_xalphas=oneAndoptional(is_xalpha,repeated(is_xalpha)) is_xpalpha=optionals(is_xalpha, is_one("+")) is_xpalphas=oneAndoptional(is_xpalpha,repeated(is_xpalpha)) Is_ialpha=oneAndoptional(Is_Alpha,repeated(is_xpalphas)) is_fragmentid=lambda is_xalphas (&lines$, &res$) -> { =is_xalphas(&lines$, &res$) } is_search=oneAndoptional(is_xalphas, repeated(many(series(one("+")),is_xalphas))) is_void=lambda (f)-> { =lambda f (&oldline$, &res$)-> { line$=oldline$ if f(&line$, &res$) then {oldline$=line$ } else res$="" =true } } is_scheme=is_ialpha is_path=repeated(oneAndoptional(is_void(is_xpalphas), series(one("/")))) is_uri=oneAndoptional(many(is_scheme, series(one(":")), is_path), many(series(one("?")),is_search)) is_fragmentaddress=oneAndoptional(is_uri, many(series(one("#")),is_fragmentid )) Flush ' empty the stack of values data "foo://example.com:8042/over/there?name=ferret#nose" data "urn:example:animal:ferret:nose" data "jdbc:mysql://test_user:ouupppssss@localhost:3306/sakila?profileSQL=true " data "ftp://ftp.is.co.za/rfc/rfc1808.txt" data "http://www.ietf.org/rfc/rfc2396.txt#header1" data "ldap://[2001:db8::7]/c=GB?objectClass=one&objectClass=two" data "mailto:John.Doe@example.com" data "tel:+1-816-555-1212" data "telnet://192.0.2.16:80/" data "urn:oasis:names:specification:docbook:dtd:xml:4.1.2" while not empty { read What$ pen 15 { Print(What$) } a$="" If is_scheme(&What$, &a$) Then Print( "Scheme="+a$ ): What$=mid$(What$,2) If is_path(&What$, &a$) Then { count=0 while left$(a$, 1)="/" { a$=mid$(a$,2): count++} if count>1 then { domain$=leftpart$(a$+"/", "/") if left$(what$,1)=":" and instr(what$,"@")0 then username$=domain$ Print "uername:"+username$ what$=mid$(what$,2) password$=leftpart$(what$,"@") Print "password:"+password$ what$=rightpart$(what$,"@") domain$=leftpart$(what$+"/", "/") what$=Rightpart$(what$,"/") end if a$=rightpart$(a$,"/") if domain$<>"" Then Print( "Domain:"+Domain$) if a$<>"" Then Print("Path:"+a$) } else.if left$(What$,1) =":" then { Print( "path:"+a$+What$): What$="" } Else Print("Data:"+ a$) } if left$(What$,1) =":" then { is_number=repeated(is_digit) What$=mid$(What$,2): If is_number(&What$, &a$) Then Print("Port:"+a$) if not left$(What$,1)="/" then exit If is_path(&What$, &a$) Then { while left$(a$, 1)="/" { a$=mid$(a$,2)} if a$<>"" Then Print("Path:"+a$) } } if left$(What$, 1)="?" then { What$=mid$(What$,2) If is_search(&What$, &a$) Then { v$="" if left$(What$, 1)="=" then { What$=mid$(What$,2) If is_search(&What$, &v$) Then Print("Query:"+a$+"="+v$) } else Print("Query:"+a$) } } While left$(What$, 1)="#" { What$=mid$(What$,2) if not is_xalphas(&What$, &a$) Then exit Print( "fragment:"+a$) } if What$<>"" Then print("Data:"+ What$) } clipboard doc$ Sub Print(a$) print a$ doc$=a$+{ } End Sub } Checkit } MODULE T1 {a=(1,2,3,4,5) Print a#rev() Print a#sum()=15 Print a#max()=5, a#min()=1 k=-1 L=-1 Print a#max(K)=5, a#min(L)=1 Print K=4 ' 5th position Print L=0 ' 1st position Print a#pos(3)=2 ' 3rd position Print a#val(4)=5 \\ tuples in tuple a=((1,2),(3,4)) Print a#val(0)#val(1)=2 Print a#val(1)#val(1)=4 a=(1,2,3,4,5,6,7,8,9) fold1=lambda ->{ push number+number } Print a#fold(fold1)=a#sum() Print a#fold(fold1,1)=a#sum()+1 even=lambda (x)->x mod 2=0 b=a#filter(even, (,)) Print b ' 2 4 6 8 Print a#filter(even)#fold(fold1)=20 map1=lambda (a)->{ push a+100 } c=b#map(map1) Print c ' 102,103, 104, 105 numbers=lambda p=1 (x) ->{ push x+p p++ } oldnumbers=numbers ' we get a copy of numbers with p=1 c=c#map(numbers) Print c ' 103, 106, 109, 112 zfilter=lambda -> number>106 tostring=lambda -> { push chrcode$(number) } oneline=lambda -> { shift 2 ' get second as first push letter$+letter$ } Line$=c#filter(zfilter)#map(tostring)#fold$(oneline,"") print Line$="mp", chrcode$(109)+chrcode$(112) zfilter=lambda -> number>200 Line$="" Line$=c#filter(zfilter)#map(tostring)#fold$(oneline,"") \\ lines$ can't change value becuse filter has no items to give Print Line$="" \\ if we leave a second parameter without value the we get No Value error Try { Line$=c#filter(zfilter, )#map(tostring)#fold$(oneline,"") } Print error$=" No value" \\ second parameter is the alternative source Line$=c#filter(zfilter,(109,112))#map(tostring)#fold$(oneline,"") Print Line$="mp" c=(1,1,0,1,1,1,1,0,1,1,0) \\ hard insert Print c#pos(1,0,1) ' 1 means 2nd position Print c#pos(3->1,0,1) ' 6 means 7th position \\ using another tuple Print c#pos((1,0,1)) ' 1 means 2nd position Print c#pos(3->(1,0,1)) ' 6 means 7th position t=(1,0,1) Print c#pos(t) ' 1 means 2nd position Print c#pos(3->t) ' 6 means 7th position } MODULE R1 {Report {Reversing a string holding the right characters in order (not reversed) Using StrRev$() we get error in third exanple This happen because some characters displayed on top of others, so we have to keep the order. We use the len.Disp() to find these characters which must glue together. } Function DispRev$(a$) { i=1: j=Len(a$): if j=0 then ="": exit z$=String$(" ",j): j++ do { k$=mid$(a$, i, 1) if ilen(a$) then exit j-- } : j-- : insert j, len(k$) Z$=K$ } else j-- :Insert j,1 z$=k$ i++ } until i>len(a$) =z$ } Print DispRev$("abcd")="dcba", StrRev$("abcd")="dcba" Print DispRev$("")="", StrRev$("")="" Report {This DispRev$("s⃝df̅")="f̅ds⃝" is true This StrRev$("s⃝df̅")="f̅ds⃝" is false } Print DispRev$("s⃝df̅")="f̅ds⃝", StrRev$("s⃝df̅")="f̅ds⃝" } MODULE W1 { Report { This is an evolutionary Algorithm, where is a target string, a fitness function which return a number of how many charachters are at the right position, but no information returned for which character is in wrong position. So we use a random solution as the start point Then algorithm make small changes and produce a number of solutions, and get the better one using the fitness function So the alogrithm produce always a same or better solution in each iteration. Finally we get the solution with the maximum fitness, which means we get the target string. Without the algorithm we need to more than 1.18376868261619E+39 strings to check Or Miliion of computational years. Here the tools to find it are two major: The small random changes The choise of a better solution from a list of solutions And a minor to make it faster After a level of fitness we use less changes (only one character), changing the starting lambda function with another. Lambda functions are first citizens in M2000. From the code the statement Dim a$(1 to gen)<{ res$="" For i=1 to 28: res$+=Mid$(L$,Random(1,27),1):next i =res$ } m$="METHINKS IT IS LIKE A WEASEL" lm=len(m$) fitness=lambda m$, lm (this$)-> { score=0 : For i=1 to lm {score+=If(mid$(m$,i,1)=mid$(this$, i, 1)->1,0)} : =score } Mutate$=lambda$ l$ (w$)-> { a=random(1,28) : insert a, 1 w$=mid$(l$, random(1,27),1) If random(3)=1 Then b=a:while b=a {b=random(1,28)} : insert b, 1 w$=mid$(l$, random(1,27),1) =w$ } Mutate1$=lambda$ l$ (w$)-> { insert random(1,28), 1 w$=mid$(l$, random(1,27),1) : =w$ } f$=randomstring$() topscore=0 last=0 Pen 11 {Print "Fitness |Target:", @(16),m$, @(47),"|Total Strings"} Print Over $(3,8), str$(topscore/28,"##0.0%"),"",$(0),f$, 0 count=0 gen=30 mut=0 { last=0 Dim a$(1 to gen)<0 Then { f$=a$(last) : gen=30 : If topscore=10 Then mutate$=mutate1$ } Else gen+=50 Print Over $(3,8), str$(topscore/28,"##0.0%"), "",$(0),f$, mut : refresh count+=min(gen,i) If topscore<28 Then loop } Print Print "Results" Print "I found this:"; a$(i) Print "Total strings which evalute fitness:"; count Print "Done" } WeaselAlgorithm } MODULE S1 {Report { Drawing 5 spheres using a lambda function each time different, which produce a texture The last one is the Transparent function which read the color of the point where we Aftr the drwaing complete we get it in cliboard as an image (a DIB type) whichw we can import to any application which imports images from clipboard. Press a key } Push key$: Drop Module CheckIt { Flush Form ! 60, 40 ' use ! to reduce form (for safe area for TV) oldback=point ' read color from 0,0 ' (Mode, Form. and Widow statement reset graphic cursor) Cls 0 ' Black Gradient 0,1 Pen 14 ' Yellow Set Fast ! Refresh 500 Module Sphere (R as long, X0 as long, Y0 as long, fun){ R2 = R * R Def Long X, Y, D2 Let Scale=twipsx/R*13.5 For Y = -R To R step twipsx { Move X0-R, Y+Y0 For X = -R To R step twipsy { D2 = X **2 + Y **2 IF R2>D2 THEN Pset Fun(Max.Data(Min.Data((Sqrt(R2 - D2) - ( X + Y) / 2 )*Scale ,255),0)) Step twipsx } } } Blue=lambda (c)->{ c1=c/4+192 =Color(c,c,c1) } Blue1=lambda (c)->{ c1=c/4+Random(150,192) =Color(c,c,c1) } Mystery=lambda m=1 (c)->{ c1=c/4+m m+=10 if m>192 then m=1 =Color(c,c,c1) } Mystery2=lambda m=1, p=true (c)->{ c1=c/4+m if p then m+=10 Else m=-10 ' we can break the if statement when e didn't use an if inside if m>192 then m-=10 : p=false If m<0 then m+=10: p=true =Color(c,c,c1) } Buffer Alfa as byte*8 \\ we place the Alfa as a closuer (Alfa is a pointer to a Buffer object) Trans =lambda Alfa (c) -> { Return Alfa, 0:=-point as long Return Alfa, 4:=-color(c,c, c/4+192) as long for i=0 to 2: Return Alfa, i:=(Eval(Alfa, i)+Eval(Alfa, i+4))/2: Next i =-Eval(Alfa, 0 as long) } Sphere 2400, 9000,7000, Blue Sphere 800, 6000, 7000, Blue1 Sphere 1200, 5000,5000, Mystery Sphere 1200, 10000,6000, Mystery2 Sphere 1200, 8000,5000, trans \\ set spped to normal (Fast is normal) Set Fast Refresh 30 copy$="" move 0,0 copy scale.x, scale.y to copy$ clipboard copy$ Print Part @(0,height),"Press a Key" A$=Key$ Cls oldback Clear ' clear variables \\ addition using clipboard.image$ to read a DIB image to string variable A$=Clipboard.Image$ Move 3000, 3000 Image A$, 6000 ' produce the image with a width of 6000 twips, and a height based on image ratio of Width/Height Move 3000,1000 Image A$, 2000,2000 ' define both width and height (stretching the image) } Checkit } MODULE M1 { Print @(tab(1)), Report { This example use code to make functions for filters to fold, and or map an array There are #functions to do that, but here we use code to do these functions (see M2) Se help #map amd help #filter tp see the use of internal functions You can follow the code using Stop where you want to stop it then use exit statement to exit From stop state you can use List amd Modules ? to see variables and modules in modules list Also you can use print or you can change variables. Try ? C to print C array at the Stop statement (see the code). From editor mark the stop staterment here and press F3 to find it at the lines bellow. Use F2 to serch back. Press a key }, width-tab(1)*2 Print Push key$: Drop Module FilterMapFold { Form 80,40 \\ HasString() \\ used to find if an array has strings or numbers \\ looking first element \\ because a is an iterator of array we have to copy first item \\ in a fresh array, which is base 0 by default \\ car(a) return first item as an array of one item \\ cdr(a) return all others as an array - not used here \\ (,) is the empty array - we can use Len() to check this HasString=Lambda (&a) ->{ z=car(a) if len(z)=0 then =false :exit link z to s() =type$(s(0))="String" } \\ FilterFold$() \\ get an array or a pointer to array or an iterator to array \\ then optional get filter \\ then get the fold function (not optional) \\ then get the initial string value - optional \\ return string FilterFold$=lambda$ HasString (w)-> { f=lambda->true res$="" Read ? f Read fold, ? res$ flush ' empty stack no other arguments allowed if not valid(w^) then {m=each(w)} else m=w if HasString(&m) then { while m { if not f(array$(m)) then continue Call fold(array$(m), &res$) } } else { while m { if not f(array(m)) then continue Call fold(array(m), &res$) } } =res$ } \\ FilterFold() \\ get an array or a pointer to array or an iterator to array \\ then optional get filter \\ then get the fold function (not optional) \\ then get the initial number value - optional \\ return number FilterFold=lambda HasString (w)-> { f=lambda->true res=0 Read ? f Read fold, ? res flush ' empty stack no other arguments allowed if not valid(w^) then {m=each(w)} else m=w if HasString(&m) then { while m { if not f(array$(m)) then continue Call fold(array$(m), &res) } } else { while m { if not f(array(m)) then continue Call fold(array(m), &res) } } =res } \\ FilterMap() \\ get an array or a pointer to array or an iterator to array \\ check to see if is an iterator, if not make one \\ then optional get filter function \\ check if has string or number \\ then optional get mapfunction \\ return a poinrer to a new array with results \\ [ ] get all items from stack and return a stack object \\ Array([]) convert stack object to array FilterMap=lambda HasString (w)-> { if not valid(w^) then {m=each(w)} else m=w f=lambda->true if HasString(&m) then { map$=lambda$->Letter$ Read ? f, map$ flush ' empty stack no other arguments allowed while m { if not f(array$(m)) then continue data map$(array$(m)) } } Else { map=lambda ->Number Read ? f, map flush ' empty stack no other arguments allowed while m { if not f(array(m)) then continue data map(array(m)) } } =Array([]) } \\ we can combine filters using filter() \\ we can have any number of lambda functions as parameters \\ if any function return false then exit and return falsa \\ so return true only if all functions return true \\ here we use it with one parameter \\ s is a pointer to stack object \\ stack(s) is a stack object as copy of s \\ ! stack(s) paste all items to current stack, the lambda stack \\ so filter return a lambda which works for any number and type of arguments \\ we use T and F as boolean values - only for print statement \\ because True and False are doubles, not boolean, but works nice in boolean expressions \\ All comparisons return boolean. Function filter { Def boolean T=True, F=False dim all() : all()=Array([]) : L=len(all())-1 =lambda all(), L , F, T -> { s=[] : =T for i=0 to L { if all(i)(!stack(s)) else =F : exit } } } \\ example for two parameters greater=lambda (x, z)->x>z divided=lambda (x, z)->x mod z=0 myfilter=filter(greater, divided) Print myfilter(10,2)=true, myfilter(2,10)=false, myfilter(7,3)=false \\ combine$() \\ take any number of lambda functions, which return string/object result \\ combine$() get all parameters to an array and make it a closure in the returned lambda \\ stackitem$() return any type from stack (string or object), without dropping it \\ because function's stack always erased at the exit, it make the drop for us. Function combine$ { dim all$() all$()=Array$([]) L=len(all$())-1 =lambda$ all$(), L -> { for i=0 to L {Push all$(i)(![])} : =StackItem$() } } \\ combine( \\ take any number of lambda functions, which return number/object result \\ combine() get all parameters to an array and make it a closure in the returned lambda \\ stackitem() return any type from stack (number or object), without dropping it \\ because function's stack always erased at the exit, it make the drop for us. Function combine { dim all() all()=Array([]) L=len(all())-1 =lambda$ all(), L -> { for i=0 to L {Push all(i)(![])} : =StackItem() } } \\ so now we see some example of using these functions \\ b is a pointer to array b=(1,2,3,4,5,6,7,8) \\ just return a copy of b Print FilterMap(b) \\ we make a lambda to be used to FilterFold \\ second parameter has to be passed by reference \\ We can use FilterFolder with String Arrays or Number Arrays \\ but we get number as result (from FilterFolder$ we get string) \\ so the reference here must be for a number \\ the first parameter here is number because we have number array to fold mul=lambda (x, &p) -> { p*=x } \\ using initial value 1 (default is 0, but here 0 isn't good) Print FilterFold(b,,mul,1) \\ so now we use the same number array but for string result \\ we make a text with one to eight starts, like a triangle of stars bar$=lambda$ (x, &ret$) ->{ ret$+=string$("*", x)+{ } } \\ Report using 2 center each line, so we get something like a tree \\ also report use proportional spacing Report 2, FilterFold$(b,,bar$) +"*" \\ we can make a new array adding three times b, so now b point to a new array b=cons(b,b,b) \\ we want the sum of all numbers in b Sum=lambda (x, &total)->{ total+=x } \\ we leave empty the filter, we place the sum function. Initial value is 0 and this is nice here. Print FilterFold(b, ,Sum) \\ We want now to get an array of all squares of even numbers in array \\ so we want the Even function as filter (return a boolean) \\ and the square function which return squares Even=lambda (x)->x mod 2=0 Square=lambda (x)->x**2 \\ this is the same Square=lambda (x) -> { =x**2 } \\ and this is the same too Square=lambda -> { Read x =x**2 } \\ or better , using Number which pop a number from lambda's stack Square=lambda ->Number**2 \\ so now we get an array with all values Print FilterMap(b, Even, Square) \\ We can get the sum too easy: Print FilterFold(FilterMap(b, Even, Square), , sum) \\ Warning \\ Each( )can't work with expression, it need a pointer to array or an array like a() \\ so we use c as a pointer to array c=FilterMap(Each(b 1 to 8), Even, Square) \\ we can see items and length Print c, len(c) \\ so now we can use each(c,1,2) to get the two first items \\ and using FilterFold we get the sum ot those two items Print FilterFold(each(c,1,2), , sum) Stop \\ We can use two dimensional arrays, or more (maximum ten dimensions) \\ we can set different base (low bound) for each dimension \\ Dim is always like a "Dim Preserve" in VB6 Dim z(1 to 4, 1 to 2) z(1,1)=1,2,3,4,5,6,7,8 \\ So now we pass z() to FilterFold, and this check that it has numbers \\ and apply the proper code to support the sum function Print FilterFold(z(), , sum) \\ no it has numbers Print HasString(&Z()) \\ so now we see examples with strings in array a=("car","boat","cat","frog") \\ check that HasString() works Print HasString(&a) ' true \\ filters \\ check if a$ has a "t" upper or lower case HasAt=lambda (a$)->instr(lcase$(a$),"t")>0 \\ check if a$ has three characters length IsThreeLetters=lambda (a$)->len(a$)=3 \\ maps \\ convert to uppercase capitalize$=lambda$ (a$)->Ucase$(a$) \\ add "123" add123$=lambda$ (a$)->a$+"123" \\ add brackets addbrackets$=lambda$ (a$)->"["+a$+"]" \\ Using filterMap with no filter/map, so we get the first two items by each() Print filterMap(each(a,1,2)) \\ now we get all items capitalize Print filterMap(a,,capitalize$) \\ now we get items with three letters capitalize Print filterMap(a,isThreeletters,capitalize$) \\ We pass a composite filter using filter() \\ so now we want items with three letters and have a "t" inside, and map to capitalize Print filterMap(a,filter(isThreeletters,HasAt), capitalize$) \\ Here we get all items with three letters an apply combine map of two functions \\ last function applied last Print filterMap(a,isThreeletters, combine$(capitalize$, add123$)) \\ Here we get all items with three letters an apply combine map \\ last applied the addbrackets so we get [CAR123] [CAT123] Print filterMap(a,isThreeletters, combine$(capitalize$, add123$, addbrackets$)) \\ So now we make a folding function \\ using string for items and by reference string for accumulator appendstring=lambda (x$, &all$)->{ all$+=x$ } \\ we get all items in a string without spaces Print FilterFold$(a,,appendstring) \\ we use each with no coma using "to" and Start and End (1 and -1), in reverse \\ so we get the items in a string in reverse order \\ reverse, we can use each(a, -1, 1) Print FilterFold$(each(a End to Start),,appendstring) \ like this Print FilterFold$(each(a,-1,1),,appendstring) \\ we can apply a filter Print FilterFold$(a,isThreeletters,appendstring) \\ or we can use the FilterMap() as a parameter for FilterFold$() Print FilterFold$(FilterMap(a,isThreeletters, combine$(capitalize$, addbrackets$)),,appendstring) \\ Another folding function, to get the total length, so we need number, \\ so we use FilterFold and not FilterFold$ GetLength=lambda (x$, &all)-> { all+=len(x$) } \\ Also we can get the maximum length from items GetMaxLength=lambda (x$, &max)-> { If len(x$)>max then max=len(x$) } \\ so now we get the length from all items with three letters Print FilterFold(a,isThreeletters,GetLength)=6 \\ and we get the maximum length from all items Print FilterFold(a,,GetMaxLength)=4 } FilterMapFold } MODULE H1 {Form 80, 66 Cursor tab(1) Report { This is an example to show how the light events in a group can be used. The theory about light events have some standards: 1, A call to an Event can be done, although this maybe do not call anything id we don't have a service function to use it 2. A servuce function has the same scope as the module we write to it. It is like we call a subroutine. But this call happen from another module, a group module. So the event call is a call BACK to module which we tie the group with DoEvents. The stack of values in event calls is new one, sp we can't a;ter the module's stack either in group module or in target module (where we tie the group with DoEvents) 3. We can't use multicast call using the light events. We have to use Evemt Object which use a list of functions to call. Event Objects can alter the finction list. The light events can't alter the service funcitons, but we can alter a function as usual by defining another time using tthe same name. This can't be happen from group module where we call the event. 4. We can make float groups from a group which has light events and we tie it to a module. The internal code in M2000 make a list of weaj references to servixe functions and when we call en event check if the weak reference exist and call it or drop the call if not exist. Prees a key }, width-tab(1)*2 Print Push Key$: Drop Class HttpStatus { Events "trace", "err","high","low" Private: myvalue Public: Enum Status { NotFound=404, MethodNotAllowed=405} Set { read x ' number or enum \\ if number not exist in enum list Then we get an error Call event "trace", x Try ok { .myvalue<=x } if not ok Then call event "err", format$("value {0} not accepted", x) } Value { =.myvalue } Operator "++" { old=.myvalue .myvalue++ if old=.myvalue Then call event "high" } Operator "--" { old=.myvalue .myvalue-- if old=.myvalue Then call event "low" } class: Module HttpStatus { .myvalue<=.NotFound } } Group WithEvents HttpStatus=HttpStatus() Function HttpStatus_trace(New a){ Print ">>>",a } Function HttpStatus_err(New a$) { Print a$ } accHigh=0 Function HttpStatus_high { Print "high limit" accHigh++ } Function HttpStatus_low { Print "low limit" } Print HttpStatus.NotFound, HttpStatus.MethodNotAllowed Print HttpStatus=404 HttpStatus=HttpStatus.MethodNotAllowed Print HttpStatus=405 HttpStatus=10 Print HttpStatus=405 \\ 404 is ok HttpStatus=404 Print HttpStatus HttpStatus-- HttpStatus++ Print HttpStatus=405 HttpStatus++ Print accHigh=1 Print Type$(HttpStatus)="Group" Def InferType$(x)=Type$(x) Print InferType$(HttpStatus)="Status" \\ for enum types Status letter Case have to match the Case in definition Module Checkit(a as Status) { Print type$(a) ' it is a enum type, not a group, so no events happen Print a a-- Print a, eval$(a)="NotFound" } Checkit HttpStatus.NotFound ' 404 404 Checkit HttpStatus ' 405 404 Print Eval$(HttpStatus)="MethodNotAllowed" Try ok { Checkit 405 } If error or not ok Then Print Error$ ' Wrong type in module A.CHECKIT Module CheckThis(a as group) { Print "ok", a=405 a++ ' raise high event, add one to acchigh } Try ok { CheckThis HttpStatus } If Error or not ok Then Print Error$ ' Wrong type in module A.CHECKTHIS \\ we can pass group not value of HttpStatus CheckThis Group(HttpStatus) Print acchigh=2 Select Case HttpStatus Case HttpStatus.NotFound Print "Not Found" Case HttpStatus.MethodNotAllowed Print "Method Not Allowed" End Select HttpStatus=HttpStatus.NotFound Module CheckThisToo(&a as group) { Print "ok", a=404 a++ ' raise high event, add one to acchigh } \\ pass by reference CheckThisToo &HttpStatus Print HttpStatus=HttpStatus.MethodNotAllowed \\ check a copy of HttpStatus to a a=HttpStatus a++ a++ ' we have no events now, a has a new cleared event list Print a =405 \\ check a pointer to HttpStatus b->HttpStatus Print Eval(b), b=>NotFound, Eval$(b=>NotFound)="NotFound" b++ ' we get event because b is a pointer to HttpStatus Try { \\ b is an object so we get wrongtype Checkit b } \\ now we can get the value from b Checkit eval(b) \\ no used & because b is actual a reference to HttpStatus \\ if we use & then we pass the reference of pointer, not the the reference of Httpstatus CheckThis b Dim a(2) \\ this is the second type of pointer, a pointer to a copy of HttpStatus a(1)->(Group(HttpStatus)) b->a(1) Print Eval(a(1))=405 a(1)-- Print Eval(a(1))=404 a(1)=405 Print Type$(a(1))="Group", InferType$(Eval(a(1)))="Status" a(1)++ ' we get high limit, because a(1) has a float group (nameless), and event list inside is the original one. b++ ' now we get high limit because b and a(1) show the same nameless (or float) group } MODULE H2 {\\ The task is simple; \\ first we make a class function to produce a group with one variable and a value \\ then we make p as a pointer to a float group produced from alfa() \\ then we use p=>x to get the x value, and eval(p) to get the group value \\ Then we want a named group, m, with a variable m to merge it with a group \\ The group is a pointer to a float group in the stack, so we push p to stack \\ We use a function which get any group (pointer on not pointer) as m \\ then make a z and then we return z as group (using Group(), because without we get the value of z, if z has a value) \\ We make the same, but now we didn't use the function but we do something else. \\ First we have to use a fresh name, say m1, and read from stack as group, so if it is a pointer we get a group from the pointer \\ now we can append a Y variable, using Group {} or using m1=class1() class alfa { x=10 value { =.x*2 } } \\ we can use p=pointer(alfa()) rem p=pointer(alfa()) rem p->alfa() Print p=>x, eval(p)=20 push p group m { y=20 } if rnd>.5 then Print "using getGroup(m)" function getGroup(m){ group z=m =group(m) } else Print "using getGroup(m as group)" function getGroup(m as group){ =group(m) } end if m=getGroup(Group) Print m=20, m.x, m.y Push p Read m1 as group if rnd>.5 then Print "using group {}" group m1 { y=20 } else Print "Using class" class class1 {y=20} \\ Let is like Push class1() : read m1 \\ without Let we get error: property can't change (there isn't a set { } session in class alfa) Let m1=class1() end if Print M1 M2=Group(M1) Print M2.y=20, M2=20 list } MODULE H3 {\\ Like H2 but p is a special pointer, a reference to alfa \\ In h2 a pointer to a float group when deleted or change pointer decrement the pointers number inside the group. So when this number goes to zero (no pointer point to foat group) then the group deleted \\ the type of pointer we use here is a reference to a named group.. Internal the pointer holds only a weak reference so if no reference exist we get error when we try to use it \\ A named group deleted when the owner (the module or function or block with temporary definitions) end the execution. We can say that a named group is a static group, but the name static used for static variables a subset of variable types which can be used for each call in a module or function or thread with only one time intialization at the Static statement. See Help Static \\ Also a named group may use Light Events. Here the "p" event may have or not a Function alfa_p. Print "Run this many times, to see all variants" counter=0 group withevents alfa { event "p" x=10 value { call event "p", 1 =.x*2 } } function alfa_p(x) { counter+=x } \\ we can use p=pointer(alfa()) rem p=pointer(alfa) rem p->alfa Print p=>x, eval(p)=20, counter push p group m { y=20 } Pen 11 {Print "We have a pointer to a group in stack"} Stack Over Pen 11 {Print "Now we have a pointer to a group in stack two times"} Stack read NewGroup def getGroup(m as group)=group(m) Print counter=1 if rnd>.5 then Pen 15 {Print "using Group reading from stack"} m=Group else Pen 15 {Print "using getGroup(m)"} m=getGroup(Group) end if Print m=20, m.x, m.y, counter m.x++ print m.x=11, alfa.x=10, p=>x=10 print m, counter Push p Read m1 as group \\ because m1 has a copy of weak reference to alfa_p and alfa_p exist Print counter=3, m1, counter=4 if rnd>.5 then Pen 12 {Print "using group {}"} \\we get a clear event list, the counter=5 return false group m1 { y=20 } Print counter=4, m1, counter=5 \\ we can make a group m2 {y=20} and a let m1=m2 to get the y without deleting the event list. else Pen 13 {Print "Using class in a let statement"} class class1 {y=20} \\ Let is like Push class1() : read m1 \\ without Let we get error: property can't change (there isn't a set { } session in class alfa) \\ the error happen if we have a value {} session which make the group as a property Let m1=class1() Print counter=4, m1, counter=5 end if def TypeExpression$(val)=type$(val) Print "m1 is a group and return a double as value" Print type$(m1), TypeExpression$(m1) \\ so we get the group not the value using group() M2=group(m1) oldcounter=counter Print counter Print M2.y=20, M2=20 Print counter if counter=oldcounter then Print "counter not changed because the event list inside group is empty" end if \\ We can get the value from NewGroup which is a pointer to a group \\ but has event list from the original alfa Print Eval(NewGroup) Print Counter \\ we use group(alfa) to get the group, not the value \\ now NewerGroup is a real pointer to a copy of alfa NewerGroup->(group(alfa)) Print Eval(NewerGroup) \\ event list also copied, and because the actual event service function exist the event served Print Counter list } MODULE INF { locale 1033 Module CheckIt { Form 66,40 Cls 5 Pen 14 \\ Ensure True/False for Print boolean (else -1/0) \\ from m2000 console use statement Switches without Set. \\ use Monitor statement to see all switches. Set Switches "+SBL" IF version<9.8 then exit IF version=9.8 and revision<18 then exit rem { \\ from revision 18 there is a constant infinity Function Infinity(positive=True) { buffer clear inf as byte*8 m=0x7F if not positive then m+=128 return inf, 7:=m, 6:=0xF0 =eval(inf, 0 as double) } K=Infinity(false) L=Infinity() } K=-Infinity L=Infinity Function TestNegativeInfinity(k) { =str$(k, 1033) = "-1.#INF" } Function TestPositiveInfinity(k) { =str$(k, 1033) = "1.#INF" } Function TestInvalid { =str$(Number, 1033) = "-1.#IND" } Pen 11 {Print " True True"} Print TestNegativeInfinity(K), TestPositiveInfinity(L) Pen 11 {Print " -1.#INF 1.#INF -1.#INF 1.#INF -1.#INF 1.#INF"} Print K, L, K*100, L*100, K+K, L+L M=K/L Pen 11 {Print " -1.#IND -1.#IND True True" } Print K/L, L/K, TestInvalid(M), TestInvalid(K/L) M=K+L Pen 11 {Print " -1.#IND -1.#IND -1.#IND True True"} Print M, K+L, L+K, TestInvalid(M), TestInvalid(K+L) Pen 11 {Print " -1.#INF 1.#INF"} Print 1+K+2, 1+L+2 Pen 11 {Print " -1.#INF"} Print K-L Pen 11 {Print " 1.#INF"} Print L-K Pen 11 {Print " True True True True"} Print L<>k, 100>K, 100>K+1, L>K Pen 11 {Print " True True 1 0"} Print L+10>100, 100+L>K, L<=>k, L<=>L } Checkit } MODULE CONV { Module Checkit { Conv2dec=lambda (n$, frombase=10, dp$=".") -> { neg=left$(n$,1)="-": if neg then n$=mid$(n$,2) if instr(n$, dp$)>0 then { n2$=Piece$(n$,dp$,2) n$=Piece$(n$, dp$,1) } else n2$="" n0=0 l1=len(n$)+1 For i=len(n$) to 1 dig$=Mid$(n$,l1-i,1) dig=asc(dig$)-48 if dig$>"9" then dig-=7 if dig>=frombase then error "not in base:"+frombase n0+=dig*frombase^(i-1) next i if n2$<>"" then { For i=1 to len(n2$) dig$=Mid$(n2$,i,1) dig=asc(dig$)-48 if dig$>"9" then dig-=7 if dig>=frombase then error "not in base:"+frombase n0+=dig/frombase^i Next i } if neg then n0-! =n0 } Conv2Any$=Lambda$ (dec, tobase=10, dp$=".", prec=16) -> { a$="" neg=false if dec<0 then neg=true dec=abs(dec) n2=frac(dec) if dec=0 then { a$="0" } else { do { n=dec mod tobase if n>=10 then n+=7 a$=chr$(n+48)+a$ dec=dec div tobase } until dec==0 } if n2<>0 then { a$+=dp$ prec-- do { prec-- dec=n2*tobase n2=frac(dec) dec-=n2 n2=round(n2) if dec>=10 then dec+=7 a$+=chr$(dec+48) } until n2=0 or prec<0 } if neg then {="-"+a$} else =a$ } Rem : Locale 1033 ' use . for all print out for decimal point Print Conv2dec("10111.01011",2); " => ";Conv2Any$(23.34375,2) Print Conv2Any$(11.90625, 2); " => "; Conv2dec("1011.11101",2) \\ using , for decimal point Print Conv2Any$(Conv2dec("1011,11101",2, ","), 10, ",") Print 12312321.1212 clipboard Conv2Any$(12312321.1212, 2) \\ using . for 1033 locale Print Str$(Conv2Dec(Conv2Any$(12312321.1212, 2), 2), 1033)="12312321.1211853" Print Str$(Conv2Dec(Conv2Any$(12312321.1212, 2,,52), 2), 1033) ="12312321.1212" } Checkit } MODULE RAT {Report { Rational Numbers Using a class Rational() which give a group object and set operators for evaluation of rational expressions A rational(10,15) is 10/15 We can make arrays of rational numbers } Module RationalNumbers { Class Rational { numerator as decimal, denominator as decimal gcd=lambda->0 lcm=lambda->0 operator "+" { Read l denom=.lcm(l.denominator, .denominator) .numerator<=denom/l.denominator*l.numerator+denom/.denominator*.numerator if .numerator==0 then denom=1 .denominator<=denom } Operator Unary { .numerator-! } Operator "-" { Read l Call Operator "+", -l } Operator high "*" { Read l g1=.gcd(l.numerator,.denominator) g2=.gcd(.numerator, l.denominator) Push l.numerator/g1*.numerator/g2 Push l.denominator/g2*.denominator/g1 Read .denominator, .numerator } Function Inverse { if .numerator==0 then Error "Division by zero" ret=This sign=Sgn(ret.numerator) : if sign<0 then ret.numerator-! swap ret.numerator, ret.denominator if sign<0 then ret.numerator-! =ret } Operator high"/" { Read l call operator "*", l.inverse() } Function Power { Read pow as long ret=This ret.numerator<=.numerator^pow ret.denominator<=.denominator^pow =ret } Operator "=" { Read l Boolean T=True, F=False if Abs(Sgn(l.numerator))+Abs(Sgn(.numerator))=0 then Push T: exit if Sgn(l.numerator) <>Sgn(.numerator) then Push F : exit pcomp=l/this Push pcomp.numerator=1 and pcomp.denominator=1 } Operator ">" { Read l Boolean F if Abs(Sgn(l.numerator))+Abs(Sgn(.numerator))=0 then Push F: exit if Sgn(l.numerator)=0 then { Push .numerator>0 } Else { pcomp=this/l Push pcomp.real>1 } } Operator ">=" { Read l if Sgn(l.numerator)=0 then { Push .numerator>=0 } Else { pcomp=this/l Push pcomp.real>=1 } } Operator "<" { Read l Boolean F if Abs(Sgn(l.numerator))+Abs(Sgn(.numerator))=0 then Push F: exit if Sgn(l.numerator)=0 then { Push .numerator<0 } Else { pcomp=this/l Push pcomp.real<1 } } Operator "<=" { Read l if Sgn(l.numerator)=0 then { Push .numerator<=0 } Else { pcomp=this/l Push pcomp.real<=1 } } Operator "<>" { Read l if Sgn(l.numerator)=0 then { Push .numerator<>0 } Else { pcomp=this/l Push pcomp.real<>1 } } Group Real { value { link parent numerator, denominator to n, d =n/d } } Group ToString$ { value { link parent numerator, denominator to n, d =Str$(n)+"/"+Str$(d,"") } } class: Module Rational (.numerator, .denominator) { if .denominator=0 then .denominator<=1 while frac(.numerator)<>0 { .numerator*=10@ .denominator*=10@ } sgn=Sgn(.numerator)*Sgn(.denominator) .denominator<=abs(.denominator) .numerator<=abs(.numerator)*sgn gcd1=lambda (a as decimal, b as decimal) -> { if a0 then .denominator/=gdcval .numerator/=gdcval end if .gcd<=gcd1 .lcm<=lambda gcd=gcd1 (a as decimal, b as decimal) -> { =a/gcd(a,b)*b } } } Print rational(-3,3)<>rational(-3,3) ' false M=Rational(10, 150) N=Rational(2, 4) Print "M.real+N.real=";M.real+N.real Print "Z=M+N" Z=M+N Print 10/150@+2/4@ Print "Z.real="; Z.real Print "(";M.numerator;"/"; M.denominator;") + (";N.numerator;"/"; N.denominator;") = (";Z.numerator;"/";Z.denominator;")" Print M.tostring$+ " +"+N.tostring$+" ="+Z.tostring$ Print -10/150@+2/4@ Z=-M+N Print "-"+M.tostring$+ " +"+N.tostring$+" ="+Z.tostring$ Print Z.numerator, Z.denominator, Z.numerator/Z.denominator Print -10/150@+2/4@ Print Z.real Z=M-N Print Z.numerator, Z.denominator Print 10/150@-2/4@ Print Z.real Z=M*N Print Z.numerator, Z.denominator Print (10/150@)*(2/4@) Print Z.real Z=M/N Print Z.numerator, Z.denominator Print (10/150@)/(2/4@) Print z.tostring$ Print Z.real Print "Z power 2 = "; Z=Z.Power(2) Print Z.real Print z.tostring$;" = ";eval(z.tostring$) Print Z=Z Print Z=N, " SHOULD BE FALSE" ' false Print Z=-Z , " SHOULD BE FALSE" ' false ZZ=-Z Print ZZ=ZZ Print -Z=-Z Print Z.numerator, Z.denominator Print Z.real, Z.tostring$ \\ Array of rational numbers Dim K(100)=rational(1,1) M=K(4)+K(3) Print M.real Print K(4).toString$ pk->(Z) Print pk=>toString$+" +" zzz=k(4)+pk Print zzz.toString$+ " ="+K(4).toString$+" +"+pk=>toString$ zzz=Rational(10,1)+Rational(3,1)*Rational(2,1) Print zzz.toString$, zzz.real=16 zzz=Rational(10,1)*Rational(3,1)+Rational(2,1) Print zzz.toString$, zzz.real=32 } RationalNumbers } MODULE TUPLE { Form 80, 60 \\ Tuple of items (as one dimension arrays) A=(1,2,3,4,5) B=("George", 10, "Bob", 5) C=(("George", 10),("Bob", 5)) Print Len(A)=5 ' true Print Len(B)=4 ' true Print Len(C)=2 ' true \\ get reference of A to A1 A1=A B1=B C1=C \\ Get Shallow Copy Dim A(), B$(), C() A()=A B$()=B C()=C A(0)=10 Print A ' 1 2 3 4 5 Print A() ' 10 2 3 4 5 Link B$() to B() B$(0)="Hello George" B(1)=1000 Print B ' George 10 Bob 5 Print B$() ' Hello George 1000 Bob 5 C()=C C(0)=("New Name", 500) Print Array(C,0), Array(C, 1) ' George 10 Bob 5 Print C(0)(), C(1)() ' New Name 500 Bob 5 \\ Test Shallow Copy \\ we keep pointer to second array but we change values \\ we need a pointer to C[1] N=Array(C,1) \\ So we can use Return to return multiple values Return N, 0:="New Bob", 1:=5000 \\ So Array(C,1) show us new values Print Array(C,0), Array(C, 1) ' George 10 New Bob 5000 \\ And because we get shallow copy (pointer only) we get C(1)() array with new values Print C(0)(), C(1)() ' New Name 500 New Bob 5000 \\ Now C(1) get a new pointer C(1)=("Another Name", 2000) Print Array(C,0), Array(C, 1) ' George 10 New Bob 5000 Print C(0)(), C(1)() ' New Name 500 Another Name 2000 \\ we can get a copy of A using Cons() with one argument NewArray=Cons(A) ' copy of A Print NewArray NewArray2=Cons(A, A) ' add A twice Print NewArray2 \\ Get a copy of C() to a pointer CopyC=Cons(C()) Print Array(CopyC, 0), Array(CopyC, 1) Return CopyC, 1:=("Just Another Name", 3000) Print Array(CopyC, 0), Array(CopyC, 1) ' New Name 500 Just Another Name 3000 Print C(0)(), C(1)() ' New Name 500 Another Name 2000 \\ Pointers for multi dimension arrays Dim A(2 to 10, 5 to 10)=1 M=A() Print Len(M) = 54 ' 9X6 Print array(M, 2,5)=1 \\ M point to a 2 dimension Array \\ Return use one dimension, so 0 is the first element Return M, 0:=1000, 6:=5000 ' 6 is the 7th item, first in second row (row, columns) Print array(M, 2,5)=1000, array(M, 3,5) Dim A(2 to 11, 5 to 10) ' add one row Print Len(M) = 60 ' 10X6 Print Type$(A(11, 5))="Empty" ' new raw has Empty as value (in calculations this is same as 0 or empty string) \\ So now we put a value For i=5 to 10:A(11,i)=1:Next i \\ we can alter last item using pointer M Return M, 59:=9999 Print A(11, 10)=9999 \\ assuming we have defalut base 0 Dim A(10,6) ' redim preserving values Print A(9, 5)=9999, Len(A())=60 \\ we can use Base 1 or Base 0 to explicit declare base Dim Base 1, A(10,6) ' redim preserving values Print A(10, 6)=9999, Len(A())=60 \\ or we can use for each dimension a new base Dim A(5 to 14, 10 to 15) ' redim preserving values Print A(14, 15)=9999, Len(A())=60 \\ Get dimensions, width for each dimension, base (min value) for each dimension, max value for each dimension Print Dimension(A())=2 ' 2 dimension Print Dimension(A(),0)=5 ' first dimension base is 5 Print Dimension(A(),1)=10 ' 10 items Print Dimension(A(),2)=6 ' 6 items, so we have 10x6 items Print Dimension(A(),1,0)=5 Print Dimension(A(),1,1)=14 Print Dimension(A(),2,0)=10 Print Dimension(A(),2,1)=15 \\ Copy all item to stack using pointer to array (not A() but M) Flush ' now stack is empty stack Push ! M ' now get 60 items Print stack.size=60 ' true Stack ' now display all stack items Flush ' now empty stack \\ if we use Push ! M we send values in reverse Data ! M ' now get 60 items \\ now all item make an array and return a pointer to Z Z=Array([]) Print stack.size=0 Link Z to Z() Dim Z(5 to 14, 10 to 15) Print Z() Print Z(14,15)=9999 Z++ ' Add 1 to all items Print Z() Z(14,15)-- ' Subtract 1 from one item Print Z(14,15) } MODULE TU {Module TestGroup { Group A { X=10 Dim K(10)=1 } Dim A(), B() A()=(A,) B()=A() A(0).X++ A(0).K(0)=1000 Print A(0).X=11, A(0).K() Print B(0).X=10, B(0).K() } TestGroup Module TestGroup2 { Group A { X=10 Dim K(10)=1 } Dim A(), B() A()=(0,) ' one item A(0)->(A) ' now A(0) has a pointer to a copy of A B()=A() A(0).X++ A(0).K(0)=1000 Print A(0).X=11, A(0).K() Print B(0).X=11, B(0).K() } TestGroup2 } MODULE PEND {Module Pendulum { thread.plan sequential back() degree=180/pi THETA=Pi/2 ' +p/8 SPEED=0 G=9.81 L=0.25 Refresh 5000 Profiler lasttimecount=0 cc=50 accold=0 ACCEL=0 'G*SIN(THETA*degree)*L time=now // fix 1.2 to 1.6 depends on machine timed=1/24/3600*(cc*1.24)/1000 Thread { time+=timed ACCEL=G*SIN(THETA*degree)*L SPEED+=ACCEL/cc THETA+=SPEED if sgn(accold)<>sgn(ACCEL) then lasttimecount=timecount: Profiler accold=ACCEL } as M interval cc Main.Task 1000/250 { Pendulum(THETA) if KeyPress(32) Then Exit } Threads Erase Sub back() If not IsWine then Smooth On Cls 7,0 Pen 0 Move 0, scale.y/4 Draw scale.x,0 Step -scale.x/2 circle fill #AAAAAA, scale.x/50 Hold ' hold this as background End Sub Sub Pendulum(x) x+=pi/2 Release ' place stored background to screen Width scale.x/2000 { Draw Angle x, scale.y/2.5 Width 1 { Circle Fill 14, scale.x/25 } Step Angle x, -scale.y/2.5 } cursor 0,1 Print time$(time,,"mm:ss"), round(lasttimecount,2), "", time$(now,,"mm:ss"), round((now-time)*100000, 2) refresh 1000 End Sub } while inkey$<>"" : end while Set Fast! Pendulum Set Fast if module(Infobasic) then keyboard "Infobasic", 13 } MODULE LOGO {font "Verdana" smooth off ' can't use xor with GDI+, so we work with GDI32 (by default) refresh 50 BackGround {refresh 50} Form 80, 50 BackGround {cls 0 :height.pixels=scale.y div twipsY : width.pixels=scale.x div twipsX } if height.pixels=1024 or height.pixels/width.pixels>0.70 then Form 80,50 else Form ! 120,55 // we use ! to add more space for TV-MONITORS - Remove it then press Esc and then F1 to save it end if Refresh 10000 Cls 5,0 Pen 14 Cursor 0,0 Move 0,0 Fill scale.x,600,5,12 move 0, 600 Fill scale.x,800,12,5 Cursor 3 drawframeM() drawframe2() drawframe0() drawframe0() drawframe0() Move 0, 1400 Cursor ! ' turn character cursor as near to graphic cursor cls, row Refresh 50 Sub drawframeM() local i, n=0 Move ! Pen 0 { Step 100, 100 For i=1 to 2 { Path n { Polygon 0, 1000, 0, 0,1000, -200,0, 0,-700,-200, 0, 0,700, -200,0, 0,-700,-200, 0, 0,700, -200, 0, 0,-1000 Step 200, 300 } Step -300, -400 n=15-n } } Step 1400,0 Cursor ! End Sub Sub drawframe2() local i, n=0 Move ! Pen 0 { Step 100, 100 For i=1 to 2 { Path n { Polygon 0, 1000, 0, 0,600, -700,0, 0,100,700,0,0,300, -1000,0,0,-600,700,0,0,-100,-700,0,0,-300 Step 200, 300 } Step -300, -400 n=15-n } } Step 1400,0 Cursor ! End Sub Sub drawframe0() local i, n=0 Move ! Pen 0 { Step 100, 100 For i=1 to 2 { Path n { Polygon 0, 1000, 0, 0,1000, -1000,0, 0,-1000 Step 200, 300 Polygon 0, 600, 0, 0,400, -600,0, 0,-400 } Step -300, -400 n=15-n } } Step 1400,0 Cursor ! End Sub } MODULE EN {if version< 9.9 Then 1000 if version= 9.9 AND REVISION<19 Then 1000 \\ by default Dog=1, Cat=2 \\ we can change it: Dog=0, Cat ' so now Cat=1 \\ we can change it: Dog=100, Cat=200 \\ we can put a new line in place of comma \\ or after comma, \\ we can't leave a comma as last character except new lines, in the enum block. Enumeration Pets { Dog Cat } a=Dog Print a=1 ' true a++ Print Eval$(a)="Cat", a=2 k=Each(Pets) While k { Print Eval$(k), Eval(k), k^ ' k^ from 0 a=Eval(k) Print a0 then Show_Folders(SubFolders) else Try ok { SubDir NewFolder1 wait 100 ' give some time to system if exist.dir("..\NewFolder1") then Print "Folder Created" Dir ..\ ' return else dir user End if } if error or not ok then Print "Error from SubDir:"+Error$ Print "Total folders="; SF.count If SF.count> 0 then Show_Folders(SubFolders) End If Win Dir$ ' open explorer in M2000 user directory Rem Win "explorer", "/select, "+dir$ ' open explorer with selected name the folder dir$ declare fs nothing sub show_members(obj) local mm=param(obj), i IF LEN(mm)>1 THEN { For i=0 to len(mm)-1 Report 3, mm$(i!) ' use index, not key Next i } end sub sub Show_Folders(obj) With obj, -4& as new Folder With Folder, "Name" as FolderName$ While Folder { Print FolderName$ } end sub } MODULE FS1 {Declare fs "Scripting.FileSystemObject" Method fs, "GetFolder", dir$ as fc With fc, "files" set files \\ Produce the TypeLib mm=param(files) IF LEN(mm)>1 THEN { For i=0 to len(mm)-1 Report 3, mm$(i!) ' use index, not key Next i } Print "Press a key ": Print Key$ With files, "count" as count if count>0 then With files, "item" set myfile ("llist1.gsb") \\ this is a property -4 which return a IEnumVariant With files, -4& as EnumFile Print Type$(EnumFile) \\ Produce the TypeLib m=param(EnumFile) IF LEN(m)>1 THEN For i=0 to len(m)-1 Report 3, m$(i!) ' use index, not key Next i End If Print "Press a key ": Print Key$ With EnumFile, "Name" as aName$ While EnumFile Print aName$ End While End if Declare fs nothing } MODULE GAME {Module Game2048 { \\ 10% 4 and 90% 2 Def GetTlleNumber()=If(Random(1,10)=1->4, 2) \\ tile Def Tile$(x)=If$(x=0->"[ ]", format$("[{0::-4}]", x)) \\ empty board BoardTileRight =lambda (x, y)->x+y*4 BoardTileLeft=lambda (x, y)->3-x+y*4 BoardTileUp=lambda (x, y)->x*4+y BoardTileDown=lambda (x, y)->(3-x)*4+y Dim Board(0 to 15) Inventory EmptyTiles \\ Score is a statement but we can use it as a variable too. Score=0 \\ Win is also a statement but we can use it as a variable too. Win=False ExitNow=False BoardDirection=BoardtileRight Process(BoardDirection) \\ Split Rem lines to insert start condition to check valid moves Rem : board(0)=2 Rem : board(1)=2, 2, 2 ' place to (1), (2), (3) While len(EmptyTiles) { NewTile() DrawBoard() Action=False do { a$=key$ if len(a$)=2 then { Action=true Select case Asc(mid$(a$,2)) Case 72 BoardDirection=BoardTileUp Case 75 BoardDirection=BoardTileRight Case 77 BoardDirection=BoardTileLeft Case 80 BoardDirection=BoardTileDown Case 79 ' End key ExitNow=True Else Action=false end select } } until Action If ExitNow then exit Process(BoardDirection) } If Win then { Print "You Win" } Else { Print "You Loose" } Refresh 30 End Sub Process(Boardtile) Inventory EmptyTiles ' clear inventory local where, i, j, k For i=0 to 3 Gravity() k=boardtile(0,i) For j=1 to 3 where=boardtile(j,i) if Board(where)<>0 then { if board(k)=board(where) then { board(k)*=2 : score+=board(where): board(where)=0 if board(k)=2048 Then Win=True : ExitNow=true } } k=where Next j Gravity() For j=0 to 3 where=boardtile(j,i) if board(where)=0 then Append EmptyTiles, where Next j Next i End Sub Sub NewTile() local m=EmptyTiles(Random(0, len(EmptyTiles)-1)!) Board(m)=GetTlleNumber() Delete EmptyTiles, m End Sub Sub DrawBoard() Refresh 2000 Cls Cursor 0, 10 Local Doc$, line$ Document Doc$ Doc$=Format$("Game 2048 Score {0}", score) \\ Using Report 2 we use rendering as text, with center justify Report 2, Doc$ Doc$={ } Local i, j For i=0 to 3 line$="" For j=0 to 3 line$+=Tile$(Board(BoardTileRight(j, i))) Next j Print Over $(2), Line$ Print Doc$=Line$+{ } Next i Report 2, "Next:Use Arrows | Exit: Press End" Refresh ClipBoard Doc$ End Sub Sub Gravity() k=-1 for j=0 to 3 { where=boardtile(j,i) if k=-1 then if board(where)=0 then k=j : continue if board(where)=0 then continue if k=-1 then continue board(boardtile(k,i))=board(where) board(where)=0 k++ } End Sub } Game2048 } MODULE FIX1 { Where=random(0, monitors-1) //mm=where=window mm=0 Title "M2000", mm font "Courier New" if mm then Hide // window as variable return monitor where the console is. Window 8, Where if mm else wait 100 back {gradient #0A0F0D, #0A0F0D} linespace 30 // we use ! after Form to leave space for TV type monitors. // you can remove ! if you have monitors Form ! 80 Cls #0A0F0D, 0 Pen 15 Push Bold Bold 0 // we make a class a function, global, which return an object of type group with additional fixme type Class fixme { f=lambda->1 remove { print "Object fixme destroyed" } } // we make a pointer to a fresh object created from fixme() function fix->fixme() // we make a lambda function with one closure, the fix which is a copy of fix // but because fix is a pointer we just get a second pointer to object fixme next_fact=lambda fix (x as long long)->{ if x<=1&& then =1&& :exit =x*fix=>f(x-1&&) } // now we pass the function next_fact (is first citizen) to fix=>f // we pass a copy. But this copy has a pointer to object pointed by fix (in the fix closure) // if we clear the memory using clear, the fix as pointer erased but the fix in lambda has a pointer, // and this pointer prevents the object for erasing. fix=>f=next_fact // we can make a copy (also we get a copy of fix, but is a pointer) m=next_fact // so now we call the next_fact() nf=next_fact(20) Print "Factorial 20 = "; nf, "Type:";Type$(nf) nf1=next_fact(21) Print "Factorial 21 = "; nf1, "Type:";Type$(nf1) Print "Redefine next_fact to use Decimal" next_fact=lambda fix (x as Decimal)->{ if x<=1@ then =1@ :exit =x*fix=>f(x-1@) } fix=>f=next_fact nf2=next_fact(21) Print "Factorial 21 = "; nf2, "Type:";Type$(nf2) nf22=next_fact(27) Print "Factorial 27 = "; nf22, "Type:";Type$(nf22) nf3=next_fact(28) Print "Factorial 28 = "; nf3, "Type:";Type$(nf3) Print "Redefine next_fact to use Double by defaultl" next_fact=lambda fix (x as Double)->{ if x<=1 then =1 :exit =x*fix=>f(x-1) } fix=>f=next_fact nf4=next_fact(10) Print "Factorial 10 = "; nf4, "Type:";Type$(nf4) nf4=next_fact(17) Print "Factorial 17 = "; nf4, "Type:";Type$(nf4) nf4=next_fact(18) Print "Factorial 18 = "; nf4, "Type:";Type$(nf4) nf4=next_fact(20) Print "Factorial 20 = "; nf4, "Type:";Type$(nf4) Print "Redefine next_fact to use Currency" next_fact=lambda fix (x as Currency)->{ if x<=1# then =1# :exit =x*fix=>f(x-1#) } fix=>f=next_fact nf5=next_fact(17) Print "Factorial 17 = "; nf5, "Type:";Type$(nf5) nf6=next_fact(18) Print "Factorial 18 = "; nf6, "Type:";Type$(nf6) fix=>f=m m1=m(20) Print "Using lambda m, Factorial 20 = "; m1, "Type:";Type$(m1) // Now we break the pointer to next_fact // Just replacing the function with a simple one // so now next_fact and m, have breaking the cycle of references. fix=>f=lambda->1 // without clear just write a Exit statement Rem Exit Print "Statement Clear - erase all module's variables" Clear Print "So now all variables destroyed" Try ok { Print m(5) } // we get "internal error in function m()" // because Print "Error"+Error$ Print "This is normal because the actual object not exist" if isnum then Bold number flush Pen 11 {print "Write Edit Fix1 to review the code"} if module(info) then print "Press F3 to return to main page" Title "M2000", 1 Show } MODULE Y {op=Pen Pen 15 Report { Y combinator in M2000 Two versions for two functions factorial and fibonacci For example (the Lamnda identifier removed for now) (g, x)->{ =g(g, x) }((g, x)->if(x=0->1, x*g(g, x-1)), 24@) We pass by value for first g this: (g, x)->if(x=0->1, x*g(g, x-1)) and for x the value 24@ (decimal type) so we call the g function passing by value the same g (lambda functions are first citizen) we never call the current function g (by using lambda() for a reccursion call) so the combinator Y combinbe two functions, the first one and the internal function g which always provide. the result from internal g is either 1 or x*g(g, x-1) depends on value of x. We use If() statement which execute only one part after arrow. a lambda function need the Lambda identifier before and we can provide This is a simple lambda: a=lambda->0 ? a()=0 ' true Now with a parameter (it is a simple form without {} and we can use it if we didn't provide a comma after) a=lambda (k)->k**2 ? a(2)=4 Or a=lambda (k)->{ ' we can use many statements ' the = statament never exit the function and is optional (without it a 0 returned) ' the function ends with a break, or an exit, or at the end of a block, and on error =k**2 } We can execute a lambda without assign a lambda to a variable, just use after arrow {funtion code here}(): Print lambda (x)->{=x**2}(2)=4 In the curly brackets we have a regular function with one diffrence. If we use closures that closures stay to lambda The closures in lambda can change state if we want. Using lambda() we can call again the same function, but closures are the same for each call If we want a lambda to return a string we use Lambda$ and for recursion lambda$() We can use lambda() and lambfa$() in any regular function. Also we can use &a to pass a lambda in a variable by reference, or &a() to pass the function by reference Passing the variable by reference we can change it and the change return back. Passing the function by reference only pass the code to a new function, but for lambda functions the clousres can be used We can define a closure in the lambda definition proviing a value, or we can just use a copy of an already defined one So we can make generators x=1 a=lambda X -> { =X X++ } Print a()=1, a()=2 See the LambdaExample in the Y code (use Edit Y) } Module Ycombinator { \\ factorial - 10@ is a decimal literal (29 digits) Print @(tab(2)), "factorial of 24 = ";lambda (g, x)->{=g(g, x)}(lambda (g, x)->if(x=0->1, x*g(g, x-1)), 24@) \\ fibonacci Print @(tab(2)),"fibonacci 10th = ";lambda (g, x)->{=g(g, x)}(lambda (g, x)->if(x<=1->x,g(g, x-1)+g(g, x-2)), 10) \\ Using closure in y, y() return function y=lambda (g)->lambda g (x) -> g(g, x) fact=y((lambda (g, x)-> if(x=0@->1@, x*g(g, x-1)))) Print @(tab(2)), fact(6)," ", fact(24) fib=y(lambda (g, x)->if(x<=1->x,g(g, x-1)+g(g, x-2))) Print @(tab(2)), fib(10) } Pen 14 Ycombinator Pen 15 Report { The lambda example } Pen 14 Module LambdaExample { x=1 a=lambda X -> { =X X++ } Print @(tab(2)), a()=1, a()=2 b=a Print @(tab(2)), a()=3, a()=4 Print @(tab(2)), b()=3, b()=4 Module Inner(&z()) { Print @(tab(2)), z(), z() } Inner &b() ' 5 6 Print @(tab(2)), b()=7 Module Inner2(z) { Print @(tab(2)), z(), z() } Inner2 b ' 8 9 Print @(tab(2)), b() ' 8 Module Inner3(&m, n) { m=n } Inner3 &b, a Print @(tab(2)), b() '5 } Pen 14 LambdaExample Pen 15 Report { A closure isn't like a static variable. A static variable has a bond with the caller A closure has a bond only with the current lambda Exception exist for those closures which are pointers, we get a copy of pointer, so maybe two lambda share the same closure, because point to same container Containers maybe anything that provide a pointer Groups may or may not provide a pointer. The Counter function use a static variable. When we pass it by reference the C() called inside Inner4 create a new static x Next time this new static used But outside the Inner4 module we use the first static So static variables are not the same as closures. } Pen 14 Function Counter { Static x=1 =x x++ } Print @(tab(2)), Counter(), Counter() ' 1 2 Module Inner4(&C()) { Print @(tab(2)), C(), C() } Inner4 &Counter() ' 1 2 Inner4 &Counter() ' 3 4 Print @(tab(2)), Counter(), Counter() ' 3 4 Pen 15 report { Except of lambda and regular functions the latest M2000 version has the analogus to subs but as functions We can call these functions as Inner Functions because can exist only in a module or in a function (lammbda or regular function) Code for inner functions always are at the end of code, after END or after END SUB We can make number or string functions. The name of a function used by the subs system, with one exception: We can call an inner function if this function has different name from any of internal functions like Abs() and Sgn(). We can replace Abs() using regular function for a module, but the @Abs() always call the internal original function. So inner functions use the @ character, so first the interpreter check if it is an internal code and then call the inner function. An inner function has the same scope as a sub, has module scope. An inner function use the same stack for values as the module (regular functions and lambdas in an expresion start with a fresh stack of values, if we call them using Call like a module then we pass the module stack). We can't call an inner function using Call or Function() and Function$(). Interpreter search for inner function the first time from the end in current code or from parent original code, but the code executed in the scope of current executed code. Goto can be used inside a Function ...End Function structure, also we can call subs or simple routines from. } \\ rules for names are like subs, but not like simple routines with Gosub to a label (which we have to use same case label) Pen 14 Print @(tab(2)), @FACTORIAL(24) Print @(tab(2)), @factorial(10) Pen 15 Report { Conclusion: For Y combinator we can use only lanbda functions which we use them as first citizens regular functions and inner functions can't be used. A regular function defined as the code executed. We can change the definition later or using an if before so we can select the code as we wish. Also we can pass it by reference. Also we can pass it to Event objects (which they hold list of functions) An inner function can't change } Pen OP Clear \\ clear all static variables End Function factorial(x) if x<2 then =1@ : Exit Function =@factorial(x-1)*x End Function } MODULE EV {Module CheckEvents { \\ we can use standard functions (not lambda functions) \\ we can use lambda() so we can use function with different names \\ We can define functions inside groups with events Group WithEvents Alfa { Event "GetIt", "PushIt" Function fib(n) { if n<=1 then { =val(n->Decimal) } else { if n<140 then { m=-1@} else m=-1 call event "Getit", n, &m if m>-1 then =m : exit \\ m1 may get double if a decimal can write the result \\ if we use m we get overflow error m1=lambda(n-1)+lambda(n-2) call event "Pushit", n, m1 =m1 } } } \\ we use an Inventory list to save old values Inventory Getit \\ event's service functions \\ if not event's functions exist, call event skipped Function Alfa_Getit { Read new key, &m if exist(Getit, key) then m=eval(Getit) } Function Alfa_Pushit { Read new key, m Append Getit, key:=m } Module Inner (&fibonacci()){ acc=0 For i=1 to 200 ' until 139 we get decimal type, above it we get double Print fibonacci(i), Next i } Form 80,32 print $(4,20), ' set: proportional text, 20 characters column width Inner &Alfa.fib() print $(0,10), ' reset: no proportional text, 10 characters column width } CheckEvents } MODULE MG {oldfont$=Fontname$ Font "Arial" Form 60,44 Escape Off Flush Flush Garbage mybg=5 Cls mybg,0 : Pen 11 Bold 1 Report "Console Input Parameters Easy" Bold 0 Cursor 0,0 : Print Under Cls , 1 \\ ValidateValue(number, letter$) \\ return a lambda function with closures And signature lambda(letter$), returning boolean \\ ValidateValue( number, number) \\ return a lambda function with closures And signature lambda(number), returning boolean Function ValidateValue { IF match("NN") Then { Read X1, Y1 =lambda X1, Y1 (n) ->{ =X1<=n And n<=Y1 ' Or n{ IF what=0 Then { =n$ ~ x1$ } Else.If what>0 Then { =n$ >= x1$ And len(n$)>what } Else = n$ >= x1$ And len(n$)>-what And n$=filter$(n$, " ") } } } \\ InpValueClass make a group \\ We can display labels, values, recording positions \\ Using ScanRange we can use arrows To move from a range of input values, in Loop \\ using Esc we get out from Loop \\ we can give two more parameters \\ the "Exit" value And a flag, IF True Then Exit IF value changed \\ mygroup=InpValueClass(#FF5522) '' need a color for background \\ \\ .Record=True needed for recording \\ .PrintLabel \\ .PrintNext \\ .PrintUp \\ .UseLastAsList \\ when we record we make ranges of input/print values And we can use \\ .RenderView To print labels/values \\ .ScanRange \\ Class InpValueClass { Private: NoKey, LastKey$, UseInteger, drawbg, overridecolors, mybg, overfr, overbg Inventory Bag, EditItems Public: Record=True, item Property mywidth { Value, Set { IF value>width Then value=width IF value<3 Then value=3 } } = 10 Property myheight { Value, Set { IF value>height-1 Then value=height-1 IF value<1 Then value=1 } }=1 Group MaxInputItem { Value { Link Parent EditItems To Ed =Len(Ed) } } Group MaxItem { Value { Link Parent Bag To Bag =Len(Bag) } } Group ItemValue { Value (akey$) { Link Parent Bag To Bag =Bag(akey$+".value") } Set (akey$) { Read mGroup Link Parent Bag To Bag IF exist(Bag, akey$+".value") Then { Return Bag, akey$+".value":=mGroup } } } Class Info { iskey, isbutton, menuitem, isnumeric Event CallBack { Read &What } ValidValue=Lambda->True myvalue$ stackA=stack X, Y, mycolor, boldface W=10, H=1 \\ only for button mybg Class: Module Info { Read .isnumeric, .iskey, .MyValue$ Read .X, .Y, .W, .H, .mycolor, .boldface, .ValidValue } } Module PrintNext { Cursor 0, Row-1 .PrintLabel } Module PrintLabel { ticket=False IF IsNum Then { ticket=1-.UseInteger Read N IF ticket=2 Then { what$=Trim$(Str$(N,"0")) } Else what$=Trim$(Str$(N)) } Else Read what$ Let colour=pen, spaces=0, boldface=0 Read ? spaces, colour, boldface bold Abs(boldface<>0) Pen colour { Print @(spaces), IF .Record Then RecordMe() IF ticket Then what$=Format$("{0}",N) IF .drawbg Then .drawbg<=False : Print @(Pos,Row,Pos+.mywidth, Row+.myheight, .mybg); IF .myheight>1 Then { Legend ! what$, .mywidth, .myheight } Else { Legend ! what$, .mywidth, 1 } Print } bold 0 Sub RecordMe() Local mylambda=lambda->True IF Not empty Then Read myLambda IF Not .NoKey Then { Append .Bag, what$:=.Info(False, true, what$, Pos, Row, .mywidth, .myheight, colour, Abs(boldface<>0), mylambda) .lastkey$<=what$+".value" \\ using = And Not <= we get Error in next call \\ becaue = make a Local variable, but .lastkey$ is a group variable. } Else { Try ok { Append .EditItems, len(.Bag) Append .Bag, .lastkey$:=.Info(ticket, False, what$, Pos, Row, .mywidth, .myheight, colour, Abs(boldface<>0), mylambda) } \\ using of Flush Error To clean Error message first IF Error Or Not ok Then Flush Error : Error "You can't record two values in same key" } End Sub } Module PrintButtonNext { Cursor 0, Row-1 .PrintButton } Module PrintButton { Read .LastKey$, caption$ Oldmybg=.mybg Read ? .mybg Push caption$ .LastKey$<=.LastKey$+".value" .NoKey~ .drawbg~ .PrintLabel .NoKey~ \\ Bag(key) Or Bag(num!) num from 0 To len(Bag)-1 Read ? event_copy there=Len(.Bag)-1 For .Bag(there!), this { .isbutton<=True .callback<=event_copy .mybg<=..mybg } swap Oldmybg, .mybg } Module PrintText (Lines, TextWidth) { Cursor 0, Row-1 .NoKey~ Let oldw=.mywidth, oldH=.myHeight .mywidth<=TextWidth .myheight<=Lines .PrintLabel swap .mywidth, oldw swap .myHeight, oldH .NoKey~ } Module UseLastAsList (ArrayA) { Read ? event_copy IF Instr(.lastkey$,".value") Else Exit For .Bag(.Lastkey$) { Stack New { Data !ArrayA .CallBack<=event_copy \\ this [] pass current stack To .StackA, and leave a new empty stack \\ [] is "[" and "]" (these chars can be used in variables names too) .StackA<=[] } } } Module InpList { a=Each(.EditItems) While a { \\ ! use position (form 0) And no key To walk in .bag() for .bag(eval(a)!) { Print .MyValue$, Len(.stackA)>0, .isbutton, .iskey } } } Group Json$ { Value (x) { ' quote$(string$(MyValue$ as json)) bag$="" nl$={ } if x<=0 then nl$="" : x=0 space$=string$(" ",x) Link Parent bag To bag a=Each(bag) While a { M= bag(a^!) For M { IF Not .iskey and Not .isbutton Then { if bag$<>"" then bag$=bag$+", "+nl$ bag$=bag$+space$+quote$(Replace$(".value","",Eval$(bag, a^-1)))+" : "+quote$(string$(.MyValue$ as json)) } } } ="{"+nl$+bag$+nl$+"}" } Set { Read bag$ c$="""" \\ this is one char 34 nl$={ } end$="" Link Parent bag To bag safety=len(bag$) Stack New { if left$(trim$(bag$),1)="{" then { bag$=Trim$(RightPart$(bag$,"{")) end$="]" } else.if left$(trim$(bag$),1)="[" then { bag$=Trim$(RightPart$(bag$,"{")) end$="}" } do { While Left$(bag$,2)=nl$ {bag$=Trim$(Mid$(bag$, 3))} bag$=Trim$(RightPart$(bag$, c$)) mkey$=LeftPart$(bag$, c$)+".value" bag$=Trim$(RightPart$(bag$, c$)) if mkey$="" then exit While Left$(bag$,2)=nl$ {bag$=Trim$(Mid$(bag$, 3))} bag$=Trim$(RightPart$(bag$,":")) While Left$(bag$,2)=nl$ {bag$=Trim$(Mid$(bag$, 3))} bag$=Trim$(RightPart$(bag$, c$)) mval$=LeftPart$(bag$, c$) bag$=Trim$(RightPart$(bag$, c$)) Group M if exist(bag, mkey$) Then { M=eval(bag) M.myvalue$<=format$(mval$) Return bag, mkey$:=M } If left$(bag$, 1)="," then bag$=Trim$(Mid$(bag$, 2)) : Restart if end$<>"" then if left$(bag$,1)=end$ then exit if safety=len(bag$) then Error "Json parse problem" safety=len(bag$) } Until bag$="" } } } Group Serialize$ { value { bag$="" Link Parent bag To bag a=Each(bag) While a { M= bag(a^!) For M { IF Not .iskey and Not .isbutton Then { IF .isnumeric Then { bag$=bag$+" "+.MyValue$ } else bag$=bag$+stack$(.MyValue$) } } } =bag$ } Set { Read bag$ Stack New { Stack bag$ \\ fill stack with special format string for stack Link Parent bag To bag a=Each(bag) Try ok { While a { M= bag(a^!) For M { IF Not .iskey And Not .isbutton Then { IF .isnumeric=1 Then { Read N .MyValue$=Trim$(Str$(N)) } Else.If .isnumeric=2 Then { Read N% .MyValue$=Trim$(Str$(N%)) } Else Read .MyValue$ } } } } If Error Or Not ok Then Flush Error : Error "Serialize Input Not Compatible" } } } Module PrintUp { Cursor 0, Row-1 .NoKey~ .PrintLabel .NoKey~ } Module PrintUpInteger { Read N Push Val(Str$(N,"0")) Cursor 0, Row-1 .NoKey~ .UseInteger~ .PrintLabel .UseInteger~ .NoKey~ } Module RenderThis { Read M Read ? offsetX, offsetY IF .overridecolors Then { mybg= .overbg } else { mybg=.mybg } local inuse, final$ For M { IF this.overridecolors and .isbutton Then exit offsetX+=.X offsetY+=.Y Cursor offsetX, offsetY IF .isbutton Then mybg=.mybg \\ from M.mybg Print @(offsetX, offsetY, offsetX+.W, offsetY+.H, mybg); IF this.overridecolors Then {inuse=this.overfr} else inuse=.mycolor Pen inuse { Bold .boldface if .isnumeric then { final$=format$( "{0}", Val(.MyValue$) ) } else final$=.MyValue$ IF .H>1 Then { Legend ! final$, .W, .H } Else Legend ! final$, .W, 1 Bold 0 } } } Module RenderView { local fromA=1, toB=-1, offsetX, offsetY Read ? FromA, toB, offsetX, offsetY, .overridecolors IF .overridecolors Then Read .overfr, .overbg N=Each(.Bag, FromA, toB) While N { .RenderThis .Bag(N^!),offsetX, offsetY } Print .overridecolors<=false } Module ScanRange { Local FromA=1, ToB=.maxitem, vert, curx, cury, mKey$ IF ToB=0 Then Exit Read ? FromA, ToB Read ? ExitC, forever Local changed .item<=FromA Field New 1 ' reset To 1 the Field internal variable. mybg=.mybg { GetAValue(.item, &changed) IF changed Then vert=False IF Field=99 Or Field=121 Then .item<=0 : Exit IF Field=1000 Then Exit IF .item=ExitC And (changed Or Not forever) Then Field New 1000 : Exit IF vert Then { vert=False IF .item>=ToB And Field=1 Then Exit IF .item<=FromA And Field=-1 Then Exit IF Field=1 Then { a=Each(.EditItems, .item+1, ToB) } Else a=Each(.EditItems, .item, FromA) last=.item Try { While a { IF Field=1 Then { for .bag(eval(a)!) { IF .x>=curx And .y>cury Then last<=a^ :Break } } Else { for .bag(eval(a)!) { IF .x>=curx And .ycurx else Break } } } } } .item<=last } IF Field=1 Then .item++ IF Field=-1 Then .item-- IF .itemToB Then .item<=FromA CONTHERE: Loop } Sub CheckOk() Refresh ok=-2 { ok=inkey(100) \\ delay 100ms IF no key pressed (return -1 IF no key pressed in 100ms) IF ok=-1 Then Loop ' any block can performe once using loop statement } Select Case ok Case 121 ' F10 oldfield=121 Case 262162 oldfield=99 Case 38 { oldfield=-1 : vert=True } Case 40 ' two Or more statements need a block after Case { oldfield=1 : vert=True} Case 39 ' left oldfield=1 Case 37 ' right oldfield=-1 Case 27, -2 { While keypress(27) {} : oldfield=99 } End Select End Sub Sub GetAValue(where, &changed) Local N,N$, posnow=Pos, rownow=Row, StackB, k$, oldfield=Field, ok IF Not Abs(oldfield)=1 Then oldfield=1 Try ok { where=val(eval$(.EditItems, where-1)) } IF Error Or Not ok Then Exit Sub Try { mKey$=Eval$(.Bag, where) } IF mKey$="" Then Exit Sub IF Instr(mKey$,".value") Else Exit Sub temp=.Bag(mKey$) For temp { Let curx=.x, cury=.y IF Len(.stackA)>0 Then { Print @(.X,.Y, .X+.W, .Y+.H, 7), IF Not .isbutton Then Mark 1,1, 8: Print " "; Pen .myColor { Bold .boldface IF .H>1 Then { Legend ! .MyValue$, .W, .H } Else Legend ! .MyValue$, .W, 1 Bold 0 } CheckOk() IF ok=13 Or ok=9 Or ok=32 Then { ShowMenu() } } Else.If .isnumeric Then { Print @(.X,.Y, .X+.W, .Y+.H, 7); Pen .mycolor { Bold .boldface Legend ! Format$("{0}",val(.MyValue$)), .W, 1 Bold 0 } CheckOk() IF ok>=96 And ok<=105 Then ok=ok-48 IF ok=13 Or ok=9 Or Chr$(ok) ~ "[0-9]" Then { N=Val(.MyValue$) Pen .mycolor { IF Chr$(ok) ~ "[0-9]" Then { IF N=0 Then {N=Val(Chr$(ok))} Else N=Val(.MyValue$+Chr$(ok)) } Print @(.X,.Y,.X+.W, .Y+.H, 7); IF .isnumeric=2 Then { N%=N Input ! N%, .W N=N% } Else Input ! N, .W } IF .ValidValue(N) Then { changed=Not .MyValue$=Trim$(Str$(N)) .MyValue$<=Trim$(Str$(N)) } } } Else { Print @(.X,.Y,.X+.W, .Y+.H, 7); IF .isbutton Then { Pen .mycolor { Bold .boldface IF .H>1 Then { Legend ! .MyValue$, .W, .H } Else Legend ! .MyValue$, .W, 1 Bold 0 } CheckOk() Field New oldfield IF ok=13 Then Call Event .callback, &This, Replace$(".value","", mKey$) : changed=True oldfield=Field } Else { N$=.MyValue$ Pen .mycolor { Bold .boldface IF .h>1 Then { Legend ! .MyValue$, .W, .H CheckOk() IF ok=13 Or ok=9 Or ok=32 Then Input ! N$, .w, .h,"Editor" } Else { Legend ! .MyValue$, .W, 1 CheckOk() IF ok=13 Or ok=9 Or ok=32 Then Print @(.X,.Y,.X+.W, .Y+.H, 7); : Input ! N$, .w } Bold 0 } IF .ValidValue(N$) Then { changed=Not .MyValue$=N$ .MyValue$<=N$ } } } IF .isbutton Then { Print @(.X,.Y, .X+.W, .Y+.H, .mybg); } Else Print @(.X,.Y, .X+.W, .Y+.H, mybg); Pen .mycolor { Bold .boldface IF .H>1 Then { Legend ! .MyValue$, .W, .H } Else { IF .isnumeric Then { Legend ! Format$("{0}",val(.MyValue$)), .W, 1 } Else Legend ! .MyValue$, .W, 1 } Bold 0 } } Field New oldfield Cursor posnow, rownow Return .Bag, mKey$:=temp End Sub Sub ShowMenu() oldfield=1 Print @(.X,.Y+1), IF Not .isbutton Then Print @(.X,.Y), :Mark 1,1, 15 : Print " "; menu fill 7,7, .mycolor menu frame off menu \\ erase menu StackB=Each(.stackA) While StackB { Menu + stackitem$(StackB) } try ok { menu show .MyValue$ } IF Error Or Not ok Then Error flush : Menu ! \\ show menu Menu fill 1 \\ reset fill colors menu frame \\ reset frame IF menu>0 Then { IF Not .isbutton Then { changed=Not .MyValue$=menu$(menu) .MyValue$<=menu$(menu) } Else .menuitem<=menu Field New oldfield Call Event .callback, &This, Replace$(".value","", mKey$) oldfield=Field IF Abs(oldfield)=1 Then oldfield=0 } Else oldfield=0 End Sub } Class: module InpValueClass (.mybg) { Read ? .mywidth, .myheight } } LocalVar$="New Title - Module scope variable" exitthis=False Function FromEvent { Read New &What, mykey$ Local K K=Ask(what.myvalue$, LocalVar$,"*") } Function FromEvent2 { Read New &What, mkey$ Local K IF what.menuitem>0 Then { IF instr(Menu$(what.menuitem),"---")>0 Then Break K=Ask(what.myvalue$+" "+Menu$(what.menuitem), "No2",,"*") If K<>1 then break IF what.menuitem=2 Then { M=InpValue2.ItemValue("Exit") M.myvalue$="Press me "+Time$(Now) InpValue2.ItemValue("Exit")=M InpValue2.RenderThis M } } Else { K=Ask(what.myvalue$, "No2") } IF mKey$="File" And what.menuitem=4 Then Field New 99 : exitthis=True : Exit Cls, -14 InpValue2.InpList } Function FromEvent3 { \\ this is a module's variable ' exitthis=True ' Field New 99 \\ We can use 1000 as default Exit Field New 1000 } Event E1 { Read &A, B$} E2=E1 ' copy of E1 To E2 FIN=E2 ' copy of E2 To FIN \\ Using Lazy$(&FromEvent()) And Not FromEvent() we pass code from module \\ when run take the module name space, so all modules variables/modules/functions are visible \\ except subrutines. Event E1 New Lazy$(&FromEvent()) Event E2 New Lazy$(&FromEvent2()) Event FIN New Lazy$(&FromEvent3()) \\ Now we have InpValue=InpValueClass(mybg) InpValue2=InpValueClass(mybg) middlepoint=0 For InpValue { .mywidth=6 .PrintButton "File","File [F10]",,,8,1,,E2 .UseLastAsList ("Menu1","Menu2","Menu3","Exit") .PrintButtonNext "Edit","Edit",,6,8,1,,E2 .UseLastAsList ("Help","Update","--------","About") } For InpValue2 { .mywidth=10 .PrintLabel "Element",,15,1 .PrintLabel "Type", 4 .PrintUp "Combo", 10, 14 .UseLastAsList ("ListBox","Combo", "TextBox", "EditBox"), E1 .PrintLabel "Name", 4 .PrintUp "Combo1", 10, 14,,ValidateValue(-3, "A") .PrintLabel "Text Field",4 Document AA$={aaaaaaaaaaaaa bbbbbbbbbbbbb cccccccccc } .PrintText 3, 30, AA$, 10,14 middlepoint=.maxitem Cursor 0, Row+4 .PrintLabel "Attributes",,15,1 .PrintLabel "Title", 4 .PrintUp "Form1", 10, 14 .PrintLabel "Top", 4 .PrintUpInteger 0, 10, 14 .PrintNext "Left",24 .PrintUpInteger 0, 30, 14 .PrintLabel "Width",4 .PrintUpInteger 4000, 10, 14, ,ValidateValue(3000, 12000) .PrintNext "Height",4+20 .PrintUpInteger 6000, 10+20, 14 .PrintLabel "Double",4 .PrintUp pi, 10, 14 .PrintNext "Double1",24 .PrintUp 2*pi, 30, 14 .PrintNext "Double2",44 .PrintUp 4*pi, 50, 14 .PrintButton "Exit","For Exit Come Here", 8, 10, 15, 1,,FIN Print "Press Esc Key" THERE: Cls, Row \\ .RenderView } \\Exit maxInputitem=InpValue2.maxInputItem do { do { InpValue.ScanRange } until Field<>121 IF exitthis Then Exit InpValue2.ScanRange 1, maxInputitem, maxInputitem-1, True } until exitthis Or Field=1000 \\ Part 2 Cls 15, 1 Pen 0 Report "Print to Paper " \\ export without buttons, black color on white paper InpValue2.RenderView 1,7, 5, 5, true, 0, 15 \\ -1 is the maxitem in bag Cursor 0,15 Report "We can move a group by offset X and Y" \\ using -1 for end mark \\ 5 chars right, 10 char lines down InpValue2.RenderView 8, -1, 5, 10, true, 0, 15 Print InpValue2.maxitem A$=InpValue2.Serialize$ Print A$ InpValue2.Serialize$=A$ A$=key$ cls mybg,1 Pen 15 Report "RenderView" InpValue2.RenderView Report "Json 2 chars indent" Pen 14 Report InpValue2.Json$(2) A$=InpValue2.Json$(0) Pen 15 { Report "Json 0 chars indent" } Report A$ Pen 15 { Report "Len json$ vs Serialize$" } Print Len(A$), Len(InpValue2.Serialize$) '' 216, 123 InpValue2.Json$=A$ Pen 15 { Report {InpValue2.Json$={"Left" : "1000", "Top" : "500"}} } InpValue2.Json$={"Left" : "1000", "Top" : "500"} Report InpValue2.Json$(0) Escape on bold true Font OldFont$ } MODULE QSORT3 {Module Checkit3 { Class Quick { Private: partition=lambda-> { Read &A(), p, r : i = p-1 : x=A(r) For j=p to r-1 : If .LE(A(j), x) Then i++:Swap A(i),A(j) Next j : Swap A(i+1), A(r) : Push i+2, i } Public: LE=Lambda->Number<=Number Module ForStrings { .partition<=lambda-> { Read &A$(), p, r : i = p-1 : x$=A$(r) For j=p to r-1 : If A$(j)<= x$ Then i++ : Swap A$(i),A$(j) Next j : Swap A$(i+1), A$(r) : Push i+2, i } } Function quicksort { Read ref$ do loop : If Stackitem() >= Stackitem(2) Then Drop 2 \\ if empty then Break else continue \\ because is hidden if empty then {Break} else continue \\ but here if empty then exit else continue end if end if over 2,2 : call .partition(ref$) :shift 3 always } } Quick=Quick() Dim A(10)<{ Link a, b to a$(), b$() def i=-1 do { i++ } until a$(i)="" or b$(i)="" or a$(i)<>b$(i) If b$(i)="" Then =a$(i)="":Exit If a$(i)="" Then =true:Exit =val(a$(i))<=val(b$(i)) } Call Quick.quicksort(&arr(), 0, Len(arr())-1) For i=0 to len(arr())-1 { Print join$(arr(i)) } \\ Fresh load Quick=Quick() Quick.ForStrings Dim A$() A$()=("one","two", "three","four", "five") Print A$() Call Quick.quicksort(&A$(), 0, Len(A$())-1) Print A$() } Checkit3 Print "See Universal - newer module" } MODULE CONC {SET SLOW // NEWER VERSIONS DON'T USE REFERESH IN THREADS (SAME AS FAST!) // SO YOU HAVE TO PLACE REFRESH WHERE YOU WANT OR // USE SET SLOW TO HANDLE IT FROM M2000 // BUT ONLY FOR EXAMPLES LIKE THIS. Thread.Plan Concurrent Module CheckIt { Flush \\ empty stack of values Data "Enjoy", "Rosetta", "Code" For i=1 to 3 { Thread { Print A$ Thread This Erase } As K Read M$ Thread K Execute Static A$=M$ Thread K Interval Random(500,1000) Threads } Rem : Wait 3000 ' we can use just a wait loop, or the main.task loop \\ main.task exit if all threads erased Main.Task 30 { } \\ when module exit all threads from this module get a signal to stop. \\ we can use Threads Erase to erase all threads. \\ Also if we press Esc we do the same } CheckIt \\ we can define again the module, and now we get three time each name, but not every time three same names. \\ if we change to Threads.Plan Sequential we get always the three same names \\ Also in concurrent plan we can use a block to ensure that statements run without other thread executed in parallel. \\ Also there is another statement (not used here): Part { code block} As Variable Look Help Part Module CheckIt { Flush \\ empty stack of values Data "Enjoy", "Rosetta", "Code" For i=1 to 3 { Thread { Print A$ Print A$ Print A$ Thread This Erase } As K Read M$ Thread K Execute Static A$=M$ Thread K Interval Random(500,530) Threads } Rem : Wait 3000 ' we can use just a wait loop, or the main.task loop \\ main.task exit if all threads erased Main.Task 30 { 'Refresh ' use refresh to show something } \\ when module exit all threads from this module get a signal to stop. \\ we can use Threads Erase to erase all threads. \\ Also if we press Esc we do the same } CheckIt Thread.Plan Sequential SET FAST } MODULE LISP {Profiler EntryLevel =0 Module forall { \\ For all subs - reusable code use Call ! Local forall Local MyAcc$ Document MyAcc$ Clear Buffer$ \\ delete command - need Clear / = is For append Call Local Parser(level, &MyAcc$) } Module Comm { Read proc$ Call ! Local forall Local dummy$=paragraph$(MyAcc$,-1,-1) Local a, d, acc Long a, d=forward(MyAcc$, a) \\ there is a backward() function too If d<>0 Then { Select Case proc$ Case "+" { While a<>0 { acc+=Val(paragraph$(MyAcc$, (a))) }} Case "-" { If a<>0 Then acc=Val(paragraph$(MyAcc$, (a))) While a<>0 { acc-=Val(paragraph$(MyAcc$, (a))) }} Case "*" { acc=1: While a<>0 { acc*=Val(paragraph$(MyAcc$, (a))) }} Else ' Case "/" { acc=1 If a<>0 Then acc=Val(paragraph$(MyAcc$, (a))) While a<>0 { acc/=Val(paragraph$(MyAcc$, (a))) }} End Select Accum$=Format$("{0}", acc)+nl$ } } Module CommWrite { Call ! Local forall Print "Lisp:"; Local i, f=Doc.Par(MyAcc$) If f>1 Then { f-- : If f>1 Then Print "("; For i=1 to f Print paragraph$(MyAcc$, i); : If i1 Then { Print ")" } Else Print } Module LoopLisp { Local dummy$ : Clear Buffer$ cnt++ : Local backhere=cnt Local mylevel=level { Call Local Parser(myLevel, &Accum$) dummy$=paragraph$(Accum$,-1,-1) \\ throw last nl$ dummy$= paragraph$(Accum$,-1,-1) Accum$=nl$ \\ insert last nl$ If dummy$="t" Then Exit cnt=backhere level=mylevel loop } } Module MyList { Local MyAcc$ Document MyAcc$ : Clear Buffer$ Call Local Parser(level, &MyAcc$) Accum$="("+Trim$(Replace$(nl$," ", MyAcc$))+")"+nl$ } Module Myif { Call ! Local forall If paragraph$(MyAcc$, 1)="t" Then { Accum$=paragraph$(MyAcc$, 2)+nl$ } else { Accum$=paragraph$(MyAcc$, 3)+nl$ } } Module DefVar { Local MyAcc$, Iddoc$ Document MyAcc$, Iddoc$ : Clear Buffer$ cnt++ Call Local Parser(level, &Iddoc$, True) Call Local Parser(level, &MyAcc$) Local id$=paragraph$(Iddoc$, 1,-1) \\ third parameter If is -1 Then delete the paragraph If id$="" Then Error "No name For variable" While Doc.Par(iddoc$)>0 { Call Local PrintNewLine "Var :"+id$ If not exist(Mem,id$) Then { Append Mem, id$:=MyAcc$ } Else Error "Variable "+id$+" already defined" id$=paragraph$(Iddoc$, 1,-1) } } Module SetVar { Local MyAcc$, Iddoc$ Document MyAcc$, Iddoc$ : Clear Buffer$ cnt++ Call Local Parser(level, &Iddoc$, True) cnt-- Call Local Parser(level, &MyAcc$) Local id$=paragraph$(Iddoc$, 1,-1) \\ third parameter If is -1 Then delete the paragraph If id$="" Then Error "No name For variable" While Doc.Par(iddoc$)>0 { Call Local PrintNewLine "Var :"+id$ If exist(Mem,id$) Then { Return Mem, id$:=MyAcc$ } Else Error "No such variable" id$=paragraph$(Iddoc$, 1,-1) } } Module Cons { Call ! Local forall Accum$=MyAcc$ } Module Remark { while cnt<=tmproof { cnt++ If mid$(a$, cnt,2)=nl$ Then cnt++ : exit } } Module String { Local check=cnt Clear Buffer$ : numeric=false while cnt<=tmproof { cnt++ If mid$(a$, cnt,1)=qu$ Then exit } if cnt-check>1 Then { Buffer$=Mid$(a$,check, cnt-check+1)} Else Buffer$={""} } Module PrintBuffer { If Doc.Len(Buffer$)>0 Then { If exist(Mem, Buffer$) and not GetQuote Then { Accum$=Mem$(Buffer$) } else Accum$=Buffer$+nl$ Call Local PrintNewLine Buffer$ Clear Buffer$ : prints++ } } Module PrintNewLine { Read New What$ If mess Then Print what$ } Module StopChar { Read New val com = val=1 level+=val If GetQuote And level<=EntryLevel Then Call Local PrintBuffer : GetQuote=false: tmproof=cnt : Exit If val<>0 Then Local oldprints=prints : prints=0 Call Local PrintBuffer If profil=1 And val=-1 Then If prints=0 Then If oldprints=prints Then Buffer$="()" : Call Local PrintBuffer profil=val } Module StopCharZero { If GetQuote And level=EntryLevel Then Call Local PrintBuffer:GetQuote=false: tmproof=cnt : Exit If com Then Call Local CheckCommand If not com Then Call Local PrintBuffer : Exit } Module StorePeriod { If Doc.Len(Buffer$)=0 Then Call Local StoreNumeric : Exit If numeric Else Call Local StoreLabel : Exit \\ see Else, same as If not numeric Then If Instr(Buffer$,".")>0 Then Call Local PrintBuffer Call Local StoreNumeric } Module StoreSign { If Doc.Len(Buffer$)>0 And numeric Then Call Local PrintBuffer : Call Local StoreNumeric : Exit Call Local StoreNumeric \\ maybe numeric=False so this is like storelabel... } Module StoreNumeric { If Doc.Len(Buffer$)=0 Then numeric=True buffer$=one$ } Module StoreLabel { numeric=False buffer$=one$ } Module CheckCommand { com=false If GetQuote Then Exit If numeric Then { If Doc.Len(Buffer$)=1 Then If Instr("*/+-",Buffer$)>0 Then Exit Exit } If Exist(commands, Buffer$) Then push eval$(commands) : Call Local letter$ } Module Sym { Read new w$ Call ! Local forall If Evall(quote$(paragraph$(MyAcc$, 1) )+ w$+ Quote$(paragraph$(MyAcc$, 2) )) Then { Accum$=t$ } Else Accum$=nil$ } Module Quote { Clear Buffer$ cnt++ Call Local Parser(level, &Accum$, True) cnt-- } Module Car { Call ! Local forall Accum$=paragraph$(MyAcc$, 1)+nl$ } Module Cdr { Call ! Local forall Local drop$=paragraph$(MyAcc$, 1,-1) Accum$=MyAcc$ } Module Eq { Call ! Local forall If paragraph$(MyAcc$, 1)=paragraph$(MyAcc$, 2) Then { Accum$=t$ } Else Accum$=nil$ } Function Parser { Read New EntryLevel, &Back$ Local GetQuote Read ? GetQuote \\ this is an optional argument For Parser Local tmproof=roof, Accum$ Document Accum$ Repeat { If leveltmproof if cnt>tmproof then Back$=Accum$ } \\ Mini lisp ver 0.01 Clear \\ clear variables Flush \\ empty stack Form ! 60,48 Print "MiniLisp Ver 0.01" Scroll Split Row \\ make this row start of scrolling screen \\ A simple lisp interpreter written in M2000 by George Karras \\For Documents "=" is For append text. Clear a$, give a new object Document. Document a$={ "hello there this is a string" ; this is going to result (write 1223345.788)(defvar Hello "M2000")(write Hello) (write 121 "Hello again...") (eq 7 7)(write (list 1 2 4 5))(defvar A (+ 7 9 13 1 5 7) ) (write A (- A 10) (* A 3) (/ 5 2)) (defvar (a b c d) 100)(write a b c d)(setq a (+ a 1))(write '(a =) a)(write (car '(a b c))(cdr '(a b c))) ; remark (write (cons 'a '(b c)))(write George 'Karras)(write (eq a 101)) (this is written as result)(write '(This written before results) (+ a 1)) (quote (Hello 1 There a b)) '(Hello 2 There a b)(eq 5 5) (loop (write a) (eq a 107) (setq a (+ a 1))) (write (list 1 A (+ A 1) 3 4 5)) (write 1 A (+ A 1) 3 4 5) (write (If t 5 6)) (write ok) (write (If nil (list 1 2 3) (list 4 5 6))) (write (If nil 5 6)) (write (If t (list 1 2 3) (list 4 5 6))) ; A form which calls the + function with 1,2 and 3 as arguments. ; It returns 6. (write (+ 1 2 3)) } Print "Parse:"; Report a$ Print nl$={ } \\ nl$ is new line Let level=0, one$="", numeric=False, prints=0, com=False, profil=1, ch10$=chr$(10),ch13$=chr$(13), qu$=chr$(34) Let mess=false '\\true \\ For messages Let cnt=1, roof=len(a$), comlevel=-1 ' no command Document Buffer$, Result$ \\ Inventory is a hash table. Inventory commands="+":="Comm {+}", "-":="Comm {-}" , "*":="Comm {*}", "/":="Comm {/}", "write":="CommWrite", "car":="Car", "cdr":="Cdr", "cons":="Cons", "defvar":="DefVar", "eq":="Eq", "setq":="SetVar", "quote":="Quote", "loop":="loopLisp",">":="Sym {>}" ,"<":="Sym {<}", ">=":="Sym{>=}","<=":="Sym{<=}", "<>":="Sym{<>}", "list":="MyList","If":="Myif" Clear t$, nil$ \\ we want a paragraph only - with new line Inventory mem \\ For variables t$="t"+nl$ nil$="nil"+nl$ Append Mem, "t":=t$,"nil":=nil$ Try ok { Call Local Parser(level, &Result$)} If Error or Not Ok Then Print Error$ If level>0 Then Error "more (" If Not Mess Then { Report 2, "Results" Report Replace$(nl$," ", Result$) } Print Timecount } MODULE P {// this is not a game is an example for how we make a game using threads and sprites. Images are simple for this example. SET FAST ! PEN #fff9aa // BLOCK ESCAPE KEY ESCAPE OFF //thread.plan sequential //WE CAN USE THREAD plan sequential also. THREAD.PLAN CONCURRENT ox=scale.x*1.4 oy=scale.y*1.4 REFRESH 500 Layer 1 { Window Mode, ox, oy CLS 1 ,0 ' COLOR BLUE AND RESET SPLIT SCREEN SETTING TO TOP LINE MOVE 1500,1000 polygon 13, 1000,-500,300,1000, -2000, -500,0, -1000 PRINT "This is first line" ' WE CAN'T SEE THE FOUR PRINTS PRINT "This is second line" 'BECAUSE WE SET A HIGH REFRESH RATE PRINT "This is third line" PRINT "This is forth line" PRINT $(1) // NOT allowed a PRINT of an item to exceed a column (1,2,3,5,6,7,8,9) MOVE 0,0 A$="" COPY 3000,2000 TO A$ GRADIENT 1, 9 ' CLEAR SCREEN WITH GRADIENT PEN 14 { FOR i=1 TO 100 { MOVE RANDOM(SCALE.X),RANDOM(SCALE.Y) CIRCLE FILL 14, RANDOM(3)*TWIPSX } } //COPY 6000,6000 TOP A$, 10, 200 //COPY 6000,6000 TOP A$, 45 //COPY 2000,2000 USE A$, 45 h$=" " Move 0,0 copy scale.x, scale.y to h$ } MOVE 6000,6000 I=1 LET X=MOUSE.X, Y=MOUSE.Y LET range=6000, ANGLE=0 LET canfire= true, fireX=0, fireY=0, firesize=0 Let sX=SCALE.X/2, sY=SCALE.Y/2 THREAD { IF abs(fireX-sx)>500 THEN { fireX=(fireX*4+SX)/5 fireY=(fireY*4+SY)/5 } ELSE { THREAD L HOLD canfire=true } } AS L e1x=6000 : e1y=6000 : e1z=20 enemy1=true THREAD { e1z+=5 IF e1z>180 OR NOT enemy1 THEN enemy1=FALSE : THREAD this HOLD } AS E1 INTERVAL 30 THREAD { e2z+=5 IF e2z>180 OR NOT enemy2 THEN enemy2=FALSE : THREAD this HOLD } AS E2 e2x=SCALE.X*.8 : e2y=6000 : e2z=20 enemy2=FALSE : THREAD e2 HOLD : THREAD E2 INTERVAL 30 THREAD { e3z-=10 IF e3z<30 OR NOT enemy3 THEN enemy3=FALSE : THREAD this HOLD } AS E3 e3x=SCALE.X*.8 : e3y=SCALE.Y: e3z=180 enemy3=FALSE : THREAD e3 HOLD : THREAD E3 INTERVAL 50 enemy4=FALSE pp=.02 X=MOUSE.X Y=MOUSE.Y // simple routine name is case sensitive GOSUB basicpart //MOVE x,y //GOSUB ship SHOW TASK.MAIN 20 { I++ IF KEYPRESS(49) THEN EXIT ' YOU CAN MAKE THE SECOND ROTATED OBJECT TO HAVE FLICKERING ' IF YOU DO THAT: ' COMMENT THE LINE BELOW AND PUT REFRESH TO 10 IN THE FIRST LINE { Move -(scale.x/2-x)/scale.x*300,-(scale.y/2-y)/scale.y*300 : Image h$ // PART USE $(4) (PROPORTIONAL TEXT), AND WRITE ONLY IN ONE LINE WITH NO WRAP PRINT PART $(0),@(0,0),"SPACE BAR TO FIRE OR KEY 1 TO QUIT" PRINT PART @(0,1),STR$(NOW,"HH:MM:SS"), e1z //, $(0),format$("({0},{1})", sX, sY) GOSUB basicpart IF enemy1 THEN { MOVE e1x, e1y STEP sx*e1z/100-SCALE.X/2, sy*e1z/100-SCALE.Y/2 SPRITE A$, 1, ANGLE/10, e1z,30+e1z/4 } IF enemy2 THEN { MOVE e2x, e2y STEP sx*e2z/50-SCALE.X/2, sy*e2z/50-SCALE.Y/2 SPRITE A$, 1, ANGLE/10, e2z,30+e2z/4 } IF enemy3 THEN { MOVE e3x, e3y STEP -( sx*e2z/100-SCALE.X/2), -(sy*e2z/50-SCALE.Y/2) SPRITE A$, 1, ANGLE/10, e3z,30+e3z/4 } IF enemy4 THEN { MOVE 8000,4000 STEP sx-SCALE.X/2, sy-SCALE.Y/2 SPRITE A$, -1, I, 100,30 } IF canfire AND KEYPRESS(32) THEN { SCORE 2, 100,"c" ' SET A MIDI MUSIC SCORE canfire~ : fireX=x : fireY=y firesize= (SQRT((SCALE.X/2)**2+(SCALE.Y/2)**2)-SQRT((x-SCALE.X/2)**2+(y-SCALE.Y/2)**2))/10 THREAD L RESTART THREAD L INTERVAL 10 PLAY 2, 10 ' PLAY THE SCORE 2 USING ORGAN 10 } else.if NOT canfire THEN { MOVE fireX, fireY TRY { PEN 4{CIRCLE FILL 4, firesize}} } MOVE X, Y GOSUB ship } IF NOT enemy1 and RANDOM(100)>95 THEN GOSUB enshow1 IF NOT enemy2 and RANDOM(100)>95 THEN GOSUB enshow2 IF NOT enemy3 and RANDOM(100)>97 THEN GOSUB enshow3 REFRESH 5000 ' DO NOW A SCREEN REFRESH ONLY IF MOUSE=1 THEN { X=MOUSE.X Y=MOUSE.Y } } // UNBLOCK ESCAPE KEY ESCAPE ON REFRESH 30 THREADS ERASE THREAD.PLAN SEQUENTIAL EXIT enshow1: e1x=6000+RANDOM(2000) : e1y=6000+RANDOM(2000) : e1z=20 enemy1=true : THREAD E1 RESTART RETURN enshow2: e2x=SCALE.X*.8-RANDOM(2000) : e2y=6000-RANDOM(2000) : e2z=20 enemy2=true : THREAD E2 RESTART RETURN enshow3: e3x=SCALE.X*.8 +RANDOM(2000): e3y=SCALE.Y: e3z=180 enemy3=true : THREAD E3 RESTART RETURN basicpart: range = SQRT((x-SCALE.X/2)**2+(y-SCALE.Y/2)**2) range2=range*2 ANGLE =(360*(SCALE.Y-y)/SCALE.Y/2)*(SCALE.X/2-x)/SCALE.X sx=SCALE.X/2-(x-SCALE.X/2)/4 sy=SCALE.Y/2-(y-SCALE.Y/2)/4 MOVE sx, sy CIRCLE 300 MOVE 0,SCALE.Y-range2/2 PEN 2 { polygon 2, 0,0,SCALE.X, 0,0, range2/2,-SCALE.X,0,0,-range2/2 } STEP SCALE.X/2,0 PEN 0 { DRAW to SCALE.X/2+(x-SCALE.X/2)/4, SCALE.Y IF 1.1-PP<1 THEN { MOVE 0, SCALE.Y-range2/2*(1.1-PP) DRAW SCALE.X,0 } MOVE 0, SCALE.Y-range2/1.9*(.9-PP) DRAW SCALE.X,0 MOVE 0, SCALE.Y-range2/1.8*(.7-PP) DRAW SCALE.X,0 IF NOT 1.1-PP<1 THEN { MOVE 0, SCALE.Y-range2/1.75*(.5-PP) DRAW SCALE.X,0 } pp+=.04 IF pp>.20 THEN pp=.02 } RETURN ship: TRY { CIRCLE 300 *(12000-range)/5000 SPRITE A$, 1, ANGLE, (12000-range)/50, 100-range/200 } RETURN } MODULE MEDITOR {\\ notepad for M2000 programs (gsb files) \\ Use F1 in editor to change to no wrap<->wrap Clear \\ Clear all variables/objects Global aLL$ Document aLL$ if exist(appdir$+"help2000utf8.dat") then Global aa, bb, where, no_par Load.doc aLL$, appdir$+"help2000utf8.dat" aa<=Val(paragraph$(aLL$, 1)) bb<=Val(paragraph$(aLL$, 2+aa)) find aLL$, paragraph$(aLL$,2+aa+1+2*bb) where<=number : no_par<=number: flush end if Flush \\ Empty the stack CurDir$=Dir$ Title$="M2000 Pad" Title "", 0 ' hide the console - 0 def docFolder$ \\ Gui Elements oldlinespace=linespace linespace 60 // using this way, setting linespace for console as ListBoxes and EditBoxes (and popup listboxe inside Combobox) // Also layer NotePad get the linespace from console, execpt we use Form statement or Linespace statement // inside a Layer NotePad { }. For the form there is no porperty named Linespace. We use statement insided Layer. Declare NotePad Form Declare Pad EditBox Form NotePad Declare HelpPad EditBox Form NotePad Declare Handle1 Listbox Form NotePad Declare File1 Combobox Form NotePad Declare Edit1 Combobox Form NotePad Declare Run1 Combobox Form NotePad Declare Help1 Combobox Form NotePad Declare Inform1 Button Form NotePad linespace oldlinespace With Handle1, "Visible" as handle1.visible, "locked" as handle1.locked, "headeronly", true, "tabstop", false, "TitleBackColor" as mcol, "top" as handle1.top Method Handle1, "UseVerMove" mcol=#FFA000 handle1.locked=true handle1.visible=false \\ we can display an icon (the M2000 by default) \\ Normal the icon is in the rright side, the control icon for close is in the left side. Here we do the oposite \\ Also we get the Quit property. Is a property which a Document read when do a busy work of loading to quit it. With NotePad,"UseIcon", True, "UseReverse", True, "Quit" as Quit \\ We nead then title height after title displayed toget the height where we place the elements, in resize event \\ we set the form to produce resize event by grabing the low right corner of form With NotePad, "Title" as Caption$, "Visible" as Visible, "TitleHeight" as tHeight, "Sizable", True \\ setting form, to show control box icon using english labels (use 0 for greek) \\ we have to place afrer "Sizable", true to have "maximeze" enabled from the start. Method NotePad,"MakeStandardInfo", 1 \\ Elements Properties (some of them changed using Methods, to pass more than one value) \\ Change bavkground to M2000 Orange Method Inform1, "Colors", 15, #FFA000 \\ We want the Button to act as a label only With Inform1, "Locked", true \\ Set the font for Pad, and for HelpPad, the two EditBoxes Method Pad, "FontAttr", "Verdana", 12, true ' size=12, bold=true Method HelpPad,"FontAttr","Verdana", 10, true \\ We call a method to setup EditBox for Text View (we can use keys to move the text) Method HelpPad, "TextViewOnly" \\ ShowAlways prevent changing color when HelpPad is inactive \\ We make some variables bound to properties With HelpPad, "visible" as helpshow, "ShowAlways", True, "Text" as HelpText$, "enabled" as HelpEnabled With HelpPad, "NoCenterLineEdit", True, "SetM2000", True, "EditDoc" as HelpEdit ' predifined for word picking \\ we want HelpPad not shown from beginning, so we disable it HelpEnabled=false With Pad, "NoWrap" as NoWrap NoWrap=True With Pad, "SetM2000", True, "SelLength" as SelLength, "HighlightParagraph", True \\ Set labels for menu's headers. and thecolor for check mark/ disable items, in menus which we have those With File1,"label","File", "Hover", true With Edit1,"label","Edit", "Mark", Color(255,100,0), "Hover", true With Run1,"label","Run", "Mark", Color(255,100,0), "Hover", true With Help1,"label","Help", "Mark", Color(255,100,0), "Id" as Id$(), "Hover", true \\ set a property variable to read/write text to pad, also we can use Tab With Pad, "Text" as Pad.Text$, "NoColor", False, "ShowAlways", True, "UseTab", True, "tabwidth", 6 \\ we want to control by menu these two properties (they can change by keystroke also) \\ F10 tongle to hidden/no hidden characters, and Ctrl+F9 change the edit style in EditBox With Pad, "showparagraph" as par_Status, "NoCenterLineEdit" as style_status \\ they are false by default par_Status=False style_status=True \\ Just for beginnig we make a function to alter the first letter of a name, to be a title Def TitleStr$(a$)=ucase$(left$(a$,1))+mid$(a$,2) Filename$=Dir$+"Untitled.gsb" \\ Caption$ is the Title property of form. This is the formula to display proper the filename$ (excluding path) Caption$=TitleStr$(File.Name$(Filename$)) +" - M2000 Pad" \\ The form is hidden, but we can move it Method NotePad,"move", 2000, 4000, 8000, 4000 \\ Also we like to give M2000 Orange to layer unter the title Layer NotePad {Cls #FFA000} \\ Now we make the menu. We set 4000 twips for each dropdown list (height calculated automatic) With File1,"MenuStyle", True, "MenuWidth", 4000 With Edit1,"MenuStyle", True, "MenuWidth", 4800 With Run1,"MenuStyle", True, "MenuWidth", 4000 With Help1,"MenuStyle", True, "MenuWidth", 4000 \\ the for This block used for erasing temporary variables, here the mi$ and mr$ \\ we have to give a Group name (anything, so here we pick "This") \\ A Menuitem without name is a line separator \\ Menuradio used in Edit1, all other are Menuitems \\ the last two items in Edit1 have a third parameter to True, which means they are checkboxes \\ Internal \\ MenuItem(a$, Optional enabledthis As Boolean = True, Optional checked As Boolean = False, Optional radiobutton As Boolean = False, Optional firstate As Boolean = False, Optional IdD) For This { const mi$="MenuItem" \\ is a temporary variable only for For This Block const mr$="MenuRadio" Method File1, mi$,"Open",true, acc:="O", ctrl:=true Method File1, mi$,"Save",true, acc:="S", ctrl:=true Method File1, mi$,"" \\ only a line here Method File1, mi$,"Close",true, acc:="C", alt:=true Method File1, mi$,"Quit",true, acc:="Q", alt:=true With File1, "MenuGroup","This" Method Edit1, mi$,"Cut",true, acc:="X", ctrl:=true Method Edit1, mi$,"Copy",true, acc:="C", ctrl:=true Method Edit1, mi$,"Paste",true, acc:="V", ctrl:=true Method Edit1, mi$,"" Method Edit1, mi$,"Less Indent",true, acc:=9, ctrl:=true, shift:=true, legend:="TAB" Method Edit1, mi$,"More Indent",true, acc:=9, ctrl:=true, legend:="TAB" Method Edit1, mi$,"" Method Edit1, mr$,"Tabs for Indent",true,true , acc:="T", alt:=true Method Edit1, mr$,"Spaces for Indent",true,false, acc:="S", alt:=true Method Edit1, mi$,"" Method Edit1, mi$,"Show Hidden Characters", true, true, acc:="F10" Method Edit1, mi$,"Free Style Edit", true, true, acc:="F9", shift:=True Method Edit1, mi$,"Wrap Text", true, true, acc:="F1" With Edit1, "MenuGroup","This" Method Run1, mi$,"Debug",true, acc:="F5", alt:=true Method Run1, mi$,"" Method Run1, mi$,"Test Slow",true, acc:="F8", alt:=true Method Run1, mi$,"Test Normal", true, acc:="F6", alt:=true Method Run1, mi$,"" Method Run1, mi$,"Settings", acc:="U", ctrl:=true Method Run1, mi$,"Default Folder", acc:="D", ctrl:=true Method Run1, mi$,"Documents Folder", acc:="D", alt:=true With Run1, "MenuGroup","This" Method Help1, mi$,"About",true, id:="ABOUT" , acc:="A", alt:=true Method Help1, mi$,"" Method Help1, mi$,"Find Topic",true ,ID:="FIND", acc:="F", alt:=true Method Help1, mi$,"Open Topic",HelpShow ,ID:="OPEN", acc:="O", shift:=true, alt:=true Method Help1, mi$,"" Method Help1, mi$,"Close Help",HelpShow ,ID:="CLOSE", acc:="C", ctrl:=true, shift:=true With Help1, "MenuGroup","This" } \\ Some variable for program. We can ue Def for a variable once, if we do that a second time the we get error. \\ always Def make local variables. We can set a type before for all non typed names after \\ or we can use as type and give a first value (not an expression here). \\ by defailt false is the va;ue for boolean type, so the =false not needed Def boolean LoadState=false, old_status=false, lastword$, old_wrap=true \\ We need some properties with inexes, so we make these as arrays \\ They look as arrays but they are objects (PropReference) \\ We can give names with dot, isn't a problem. Dot can be used for any name With Edit1,"ListSelected" as Edit1.Selected(), "MenuEnabled" as Edit1.Enabled() With Help1, "MenuEnabled" as Help1.Enabled() \\ Some variables for specific task. \\ Document make or change a local string variable (or global using <=) to a Document type object (a linked list of paragraphs) \\ we have to use Clear Name$ to erase the document's paragraphs. \\ Using = or <= for globals we append text to it Document BackUp$="\\Write something...", LoadFile$ Def ok as boolean Const nl$=chr$(13)+chr$(10) Pad.Text$=BackUp$ Def what$, lastcommand$, mod2run$ \\ function to retrieve info from help database, help2000.mdb in appdir$ Def boolean HelpView if doc.par(aLL$)=0 then \\ Old for HelpM2000.mdb Function GetHelp$(&word$, findit) { word$=ucase$(word$) Eng=chrcode(word$)<128 If findit Then Retrieve appdir$+"HELP2000", "Select * FROM [COMMANDS] WHERE "+If$(Eng-> "ENGLISH","DESCRIPTION")+" Like '"+word$+"%'",1,"","" Else Retrieve appdir$+"HELP2000", "COMMANDS",1,If$(Eng->"ENGLISH","DESCRIPTION"),word$ End If If number>0 Then read new word1$, hlp$, word2$ =If$(Eng->RightPart$(hlp$,"____"), LeftPart$(hlp$,"____")) : word$=If$(Eng->word2$, word1$) End If } Else Function GetHelp$(&word$, findit) { Local Nword$=ucase$(word$) select case Nword$ case "ΓΕΝΙΚΑ" Nword$="ΟΛΑ" case "GENERAL" Nword$="ALL" End Select if findit then find aLL$, "\"+Nword$, where else find aLL$, "\"+Nword$+"!", where end if Read Where1 if Where1>0 then Read There : drop Ret$=mid$(Paragraph$(aLL$, There), 2) Word$=leftpart$(Ret$,"!") lbl=Val(Rightpart$(Ret$,"!")) info=Val(Rightpart$(Ret$,"-")) if info=0 then ="["+LeftPart$(Paragraph$(aLL$,lbl+1), ", ")+"] "+format$(paragraph$(aLL$, 2+aa+1+There-no_par)) else ="["+RightPart$(Paragraph$(aLL$,lbl+1), ", ")+"] "+format$(paragraph$(aLL$, 2+aa+bb+info)) end if end if } End If \\ this call using Call Local (otherwise we get error because GetHepl$() isn't a global, or a local to FindWord) Function FindWord() { read new word$, find=false Local hlp$=GetHelp$(&Word$, find) If len(hlp$) else exit lastword$=word$ HelpText$=word$+nl$+hlp$ If not helpview Then helpview=true : helpenabled=true Call Local Notepad.Resize(true) } \\this call using Call Local too, because inform1 is in this module scope \\ we use letter$ to pop a string (so we don't have to make a variable first) Function InformNow { With Inform1, "Caption", letter$ } \\ so now we have to make some event service functions. \\ all these functions call local, means they use the same namespace as the one which the object defined \\ we have to use Read New or place a new in parameter list () like in NotePad.Unload \\ this prevents to use a same local variable. Events may be called again, while still executed \\ to prove that we have to open a big file (rename a big txt file as gsb, say bigger than 10Mbytes) \\ then open it, and before actual placed in Pad, we can use he same service function to close the NotePad \\ Form's Events (NotePad is the object) \\ The NotePad.Unload event get an argument by reference. If this change to true the unload canceled Function NotePad.Unload(New &Ok) { If LoadState Then Quit=true : Call Local InformNow("Quit Loading..") : Exit If Pad.Text$<>BackUp$ Then After 50 {Call Local File1.DblClick(4)} Ok=True End If } \\ we can change this in code if we change the font of title (because a new TitleHeight prodced), or if we remove the header (make it invinsible) def third, free third=1000 With NotePad, "Width" as NP.Width, "Height" as NP.Height, "TitleHeight" as tHeight Method File1,"move", twipsX*3, tHeight, twipsX*80, tHeight Method Edit1,"move", twipsX*3+twipsX*80, tHeight, twipsX*80, tHeight Method Run1,"move", twipsX*3+twipsX*160, tHeight, twipsX*80, tHeight Method Help1,"move", twipsX*3+twipsX*240, tHeight, twipsX*80, tHeight Method Inform1,"move", twipsX*3+twipsX*320, tHeight, twipsX*160, tHeight Function Notepad.Resize { Local FromHelp=false if match("N") then Read FromHelp Layer NotePad { Cls Color(255, 160, 0) ,0} local tHeight1=theight*2 Local free=NP.Height-tHeight1-twipsX*3 local oldhelpshow=helpshow If NP.height>1800 Then { If helpview Then if oldhelpshow else Method Handle1, "move",twipsX*3, tHeight1+free-free/3-twipsX*3, NP.Width-twipsX*6,twipsY*3 end if if handle1.locked then handle1.locked=false local third=handle1.top-tHeight1 if thirdpar_status Then With Inform1, "Caption",If$(par_status->"Hidden", "No Hidden") old_status=par_status else.if old_wrap <> NoWrap then With Inform1, "Caption",If$(NoWrap-> "No Wrap", "Wrap Text") old_wrap=NoWrap Else With Inform1, "Caption", format$("{0}-{1}", L,P) End If \\ set focus to Pad - refresh if not scheduled Method Pad,"Show" } \\ Helper functions for Edit1 Function SetTabs { With Pad, "UseTab", True,"tabwidth",6 With Inform1, "Caption","Set Tabs" Method Pad,"Show" } Function SetSpaces { With Pad, "SpaceIndent", 6 With Inform1, "Caption","Set Spaces" Method Pad,"Show" } Function ChangeHidden { Edit1.Selected(10)=not par_Status Method Pad,"PressKey", 121, 0 ' 121=vbkeyF10 old_status=par_status With Inform1, "Caption",If$(Edit1.Selected(10)->"Hidden", "No Hidden") Method Pad,"Show" } Function ChangeStyle { Edit1.Selected(11)=not style_status Method Pad,"PressKey", 120, 1 \\ no need to refresh, the effect is internal, and we see the cursor \\ to leave the center line if free style used, not only in top or bottom page } Function ChangeWrap { old_wrap~ Edit1.Selected(12)=not old_wrap NoWrap=old_wrap With Inform1, "Caption",If$(NoWrap-> "No Wrap", "Wrap Text") ' Method Pad,"Show" } \\ Befor Edit1 opened Function Edit1.OpenMenu { Local X X=SelLength>0 Edit1.Enabled(0)=X Edit1.Enabled(1)=X Edit1.Selected(10)= par_Status Edit1.Selected(11)= style_status Edit1.Selected(12)=Not NoWrap } \\ We can check in checkboxes and radiobutton withou closing the menu \\ if we click on checks - (not on names) \\ here we use If Else.If Else End If Function Edit1.MenuChecked { Read New RadioIndex If RadioIndex=7 Then Call Local SetTabs() Else.If RadioIndex=8 Then Call Local SetSpaces() Else.If RadioIndex=10 Then Call Local ChangeHidden() Else.If RadioIndex=11 Then Call Local ChangeStyle() Else.If RadioIndex=12 Then Call Local ChangeWrap() Else With Inform1, "Caption","??" Method Pad,"Show" End If } \\ When we double click on a menu item \\ We use Select Case \\ In M2000 after a Case can be one line of commands, or a block of commands {} \\ but no two or more lines of commands Function Edit1.DblClick { Read New Edit1index Select Case Edit1index Case 0 Method Pad,"mn1sub" : Method Pad,"Resize" Case 1 Method Pad,"mn2sub" Case 2 Method Pad, "mn3sub" : Method Pad,"GetFocus" : Method Pad,"Resize" Case 4 Method Pad,"PressKey", 9, 1 Case 5 Method Pad,"PressKey", 9, 0 Case 7 Call Local SetTabs() Case 8 Call Local SetSpaces() Case 10 Call Local ChangeHidden() Case 11 Call Local ChangeStyle() Case 12 Call Local ChangeWrap() End Select } \\ Prepare the Run part Document TestFile$ UseShow$={ Use statement Show to select when console open. Use { END } to skip waiting for key before end } \\ 0,2,3 menuitems call the same \\ 1 is the line separator Function Run1.DblClick { Read New Run1index if Run1index=1 then exit else.if Run1index=5 then Clear TestFile$ Prototype { Module A { Title "Settings", 0 Settings Wait 2000 While Control$="SETTINGS" Wait 500 End while } A : End } as TestFile$ Save.Doc TestFile$, "Test1235.gsb" Win appdir$+"m2000.exe", dir$+"Test1235.gsb" else.if Run1index=6 then dir user local n=ask("Directory:"+nl$+dir$, "Information","ok","") else.if Run1index=7 then local olddir$=dir$ if docFolder$<>"" then dir docFolder$ dir ? "*","Documents Folder" docFolder$=dir$ dir olddir$ else.If ask(if$(Run1index=0->"Module to run","Command(s) to execute" +UseShow$),,,,,mod2run$)=1 Then Read mod2run$ Clear TestFile$ TestFile$=If$(Run1index=2->"Set Slow"+nl$,"") if docFolder$<>"" then TestFile$="Dir "+docFolder$+nl$ TestFile$="Module TestThis {"+Pad.Text$+nl$+"}"+nl$ TestFile$="Title "+quote$(LeftPart$(Caption$," -"))+nl$ TestFile$="Script TestThis :"+If$(Run1index=0->"Test ","")+mod2run$+": Push Key$: Drop: End" Save.Doc TestFile$, "Test1234.gsb" Win appdir$+"m2000.exe", dir$+"Test1234.gsb" End If } \\ This is the File1 DblCkick event \\ We use On Goto who start from 1, so we add one to File1index \\ We use labels and goto because the logic is a kind of spagheti \\ From Open1: may we go to Save1: \\ From Unload: we go to Save2: \\ From Save2: may we go to Save1: \\ There several cases to exit \\ the code use If with blocks {} ' not updated yet \\ The Break statement stopped only from a Try {}, \\ so Break make exit from all blocks, and exit from function. Function CheckText(a as string) { if exist(a) then if filelen(a)>0 then object z=buffer(a) where=instr(eval$(z), str$(chr$(13)) as byte) =where>0 and where<2000 else boolean T=True =T end if end if } Function File1.DblClick { Read New File1index Local cont, cont2, f$, nl$={ } File1index++ \\ Because we want some jumps..we use On Goto \\ on Goto need here a block { On File1index Goto Open1, Save1, ExitNow, Save2, Unload Exitnow: Exit Open1: If Pad.Text$<>BackUp$ Then { If ask("Save Changes first?",Title$)=1 Then Goto Save1 } Layer NotePad { \\Using "**" we can go up to drives. Try ok { Open.file filename$,"**","Load M2000 (Gsb) File","gsb" } If not ok Then push "" : Dir User } Method Pad,"GetFocus" Read f$ If f$<>"" Then if exist(F$) then { If CheckText(F$) Then Clear LoadFile$ Method Pad,"PressKey", 0, 0 LoadState=true Call Local InformNow("Loading...") layer NotePad { Load.Doc LoadFile$, f$ } \\ set the current directory If quit Then break Filename$=f$ dir file.path$(Filename$) If not quit Then Caption$=TitleStr$(File.Name$(Filename$)) +" - M2000 Pad" Clear Backup$ BackUp$=LoadFile$ Clear LoadFile$ Pad.Text$=BackUp$ End If Else Local A, info$ Info$={ This file has not text (it is probably an encrypted file) } A=Ask(info$,Title$,"","") end if } Else Pad.text$="": Clear BackUp$ Call Local InformNow("Rendering...") Method Pad, "Resize" Call Local InformNow("Ready...") LoadState=false End If Exit Save1: Layer NotePad { try ok { Save.As Filename$,"**","Save M2000 File","gsb" } If not ok Then Push "" : Dir User } If not cont2 Then Method Pad,"GetFocus" Read f$ If f$="" Then Exit If lcase$(file.type$(f$))<>"gsb" Then f$=f$+".gsb" If Exist(f$) Then If Ask(nl$+"Overwrite"+nl$+f$,Title$)<>1 Then Exit Try ok { Clear BackUp$ BackUp$=Pad.Text$ Save.Doc BackUp$, f$ filename$=f$ dir file.path$(Filename$) Caption$=TitleStr$(File.Name$(Filename$)) +" - M2000 Pad" } If ok Else beep If not cont Then Exit Save2: cont=True If Pad.Text$<>BackUp$ Then { If ask("Save Changes?",Title$,"*SAVE", "CANCEL")=1 Then Goto Save1 } Clear BackUp$ Pad.Text$="" If Cont2 Then Dir CurDir$ Method NotePad, "CloseNow" Else //if docFolder$<>"" then dir docFolder$ FileName$=Dir$+"Untitled.gsb" Caption$=TitleStr$(File.Name$(Filename$)) +" - M2000 Pad" Method Pad, "Resize" Method Pad,"GetFocus" End If Exit Unload: Cont2=True : Goto Save2 } } \\ These are the Help1 events \\ We want to enable/disable 3 and 5 menuitems GetIndex=lambda Help1 (id$) ->{ ret=-1& Method Help1, "GetMenuId", id$, &ret as ok if ok then =ret else =-1& } Function Help1.OpenMenu { Help1.Enabled(GetIndex("OPEN"))=HelpShow and not HelpEdit Help1.Enabled(GetIndex("CLOSE"))=HelpShow } Function Help1.DblClick { read new Help1.index call local InformNow(id$(Help1.index)) Select Case id$(Help1.index) Case "ABOUT" { Local A, info$ Info$={ This is an example of a notepad for M2000 Programs written in M2000 and run in M2000 Environment. Choose a blue word and press ctrl+f1 or F for help. } A=Ask(info$,Title$,"","") } Case "FIND" Call Local HelpPad.click() Case "OPEN" Method HelpPad, "EditTextView", True: Call Local Notepad.Resize(true) Case "CLOSE" Method HelpPad, "EditTextView", false : HelpView=false: handle1.visible=false: Call Local Notepad.Resize(true) End Select } Function Handle1.ValidMove { Drop Read New &Y mcol=7 if yNP.Height-tHeight then y=NP.Height-tHeight } Function Handle1.MouseUp { Call Local Notepad.Resize() mcol=#FFA000 } Function HelpPad.Word() { Call Local FindWord(letter$, false) } \\ this work with help Function Pad.Word() { lastword$=letter$ } Function Pad.Help { Read New what$ :Call Local FindWord(what$, true) } Function Pad.About { Call Local FindWord("ALL", true) } Function Notepad.InfoClick { Read New X If X=0 Then Call Local Help1.DblClick(0) ' 0 for first menu item } Call Local Notepad.Resize() \\ make this as the default control (get focus) With Pad,"Default",True \\ open as modal With NotePad, "Blink", 50, "BlinkTimes", 20 Method NotePad,"Show", 1 Declare Pad Nothing Declare NotePad Nothing If Module(Info) Then Title "Info" end if } MODULE INFOBASIC {Italic 0 Bold 1 if fontname$<>"Verdana" then font "Verdana" Set Edit !4 ' 4 chars fpr tabs in edit \\ \\ Press Esc to exit this editor - look the context drop down menu too (ctrl+F10 also open context dropdown menu) \\ \\ refresh 10000 cls 0,0 \\ window show again window 6, window refresh 10000 linespace 0 wait 100 BackGround { cls 0,0 height.pixels=scale.y div twipsY width.pixels=scale.x div twipsX sx=scale.x sy=scale.y } Window 12, Window BackGround {cls,0 } form 100; linespace 15 backcolor=5 'point oldpen=14 ' pen Pen 0 { cls 7 ico 1 ' draw icon (a png image, loaded as text as BASE64 encoded) Double Print part " ";~(1);" M2000 Interpreter";~(#2222bb);str$(version)+if$(revision>0->" ("+str$(revision,0)+")","") Print Normal italic Report " A collection of modules for tests version 58 for M2000 Interpreter version 12, revision 19 and above" italic Pen 5{ cursor 0, row-1 Report 1, "George Karras 2022-2023" } } cls backcolor, row Scroll split 0 ' reset the row+1 which given in cls pen oldpen Clear ' clear local variables title("Modules ?") Report { Modules ? (or control+N, display all loaded modules, If nothing loaded display files) Modules ? "","Print" (search all loaded modules for those who have Print in any case like PrINt) You can call any module by name, try Info Modules (Show every loaded module, plus files on user folder) *** Use module Caret (write Caret and press enter) to adjust caret blinking timeout } Pen 15 { Modules ? Print } title("List") Report { You can see the global variables, If any exist, defined in console (write A=10, press enter then press F3 ) Use statement Clear to clear all variables (including static variables if any). If a module not run as expected use CLEAR before run the module. } Pen 11 {List} title("Stack") Report { You can see the stack of values, If has any value. Use statement Flush to empty the stack } Pen 11 {Stack} title("Useful Statements") Report { Help All, Help Print, Help | Monitor (to see switches), shitches (some staments can be used from a module using the Set statement) (Set Monitor - because Monitor is known to Console Interpreter) Edit info (press esc to exit editor) | Edit "disk_file.gsb" (to edit from disk - saved at exit) Edit (no argument) open command editor (we pick in console line using up/down arrows) Save filename (without quotes, except If we want spaces) | load filename (filename without "" and type) Settings (open dialog for setting environment) | Start ' restart console Use filename (use info open another info in another console) | Dir to show current directory or Dir user to set current dir to user folder Files "GSB","PRINT|FOR" (search files *.gsb for words PRINT and FOR) | Win Dir$ | Win Calc | Win Appdir$ | End (to exit from console) } Fkey Clear FKey 1,"Saveme ' save all loaded modules" FKey 2,"Logo : Edit InfoBasic : hide : InfoBasic ' edit this" FKey 3,"InfoBasic ' this page" FKey 4,"M2000_Editor_Information ' about editor" FKey 5,"Demo1 ' 3d Drawing in a Window" \\FKey 6,"Edit M2000_editor_information" FKey 6,"icons ' an example using sprites of type png" Fkey 7,"Tr 'Three Oscilloscopes" Fkey 8,"mEditor ' A window based M2000 Editor" Fkey 9,"kb ' A keyboard to play music" FKey 10,"Settings" FKey 11,"Dijkstra" Fkey 24, {chessgame "rnb2rk1/ppp1q1pp/5n2/2bpp3/2Q1p3/1B3P2/PPPP1NPP/RNB2RK1 w - - 0 10"} Fkey 12, "chessgame" FKey 19,"List33 ' Listbox control Example" FKey 18,"Form44 ' Muliple Windows Example" FKey 17,"Maze2 ' Maze Drawing in console" FKey 16,"Cal ' Snoopy Calendar" FKey 15,"OOP1 ' EventHandler Class" FKey 14,"Pend ' Pendulum Animation" FKey 20,"Pong ' SoloPong - for one player" Fkey 21, "minesweeper ' edit the code to change the game board size" FKey 22,"Jukebox 'Play mp3, non stop music" Title("Fkey") Report { Fkey + Enter to see the Function Keys } \\title("M2000 Writer") \\Keyboard "Writer"+chr$(13) back {refresh 50} Refresh 50 show end Sub title(a$) Pen #ffeeff { cursor 0 Italic 1 Report a$ Italic 0 cursor 6, row-1 } End Sub } MODULE SAVEME {Print "Wait..." Title "Info" dir user save info, {UseThis : InfoBasic : C1: ShowKeys: Pen 15 {Print "Press F3 now"}} Print "Done" } MODULE M2000_EDITOR_INFORMATION {\\if width<>80 and height<>66 then window 10, window : form !80,66 font "verdana" form ! 80, 66 thread.plan sequential ' can run as concurrent too linespace twipsY*2 ' Mode as read only value return the height of layer form in pt. Using Mode we set to the same Mode but we cut extra space (use linespace also) Mode Mode 'Cls,0 backcolor=point oldpen=pen Refresh 500 Pen 0 { cls 7 call ico, 1 Double Print part " M2000 Interpreter"+str$(version)+" ("+str$(revision,0)+")" Print Normal Report " Internal M2000 Editor" Pen 5{ cursor 0, row-1 Report 1, "George Karras 2022-2023" } } cls backcolor, row pen oldpen title("Define a Module") Report { Edit Alfa (open editor to edit Alfa Module, and all modules/functions inside of it) }, width-12 title("Define a Function") \\ we can't put a left parenthesis without a match right parenthesis (including for strings) in a { } string literal Report { }+"Edit Alfa() or Alfa("+{ (open editor to edit Alfa() Function, and all modules/functions inside of it) } title("Open for edit at specific position") Report { Edit Alfa, 100 } title("Indent a line") Report { just press tab before any letter, to delete indentation mark the text shift +End and then press shift tab You can start a indentation with spaces (Default is tab - characrer 9), using shift tab in a clear line, or a line without leading tabs. }, width-12 title("Indent multiple lines")Report { Mark a block and then press tab or shif tab to move text right or left }, width-12 title("Functions Keys for Editor") Report { F1 - Toggle Wrapping setting (on or off) F2 - search marked or last searched word/characters up using shift to search characters using ctrl to search words (both open a messabox) F3 - search marked or last searched word/characters down using shift to search characters using ctrl to search words (both open a messabox) F4 - change the letters case using the marked word (no undo for this) F5 - Replace marked word with one we provide in inputbox (multiple undo) - using shift replace characters - Ctr-Z undo the action F6, F7, F8 Bookmarks. One press for Set, Delete, Goto Bookmark. Messages displayed F9 - Count words - Shift F9 change Editor Style F10 - Show hidden characters (paragraph, spaces as dot, nbsp as space, figure space, tab) F10 & Shift - Open Popup Menu F11 - Change Syntax Color On, Language Width Normal, Syntax color Off, Language Width Small F12 - Open a form displaying all names of loaded modules, we can click on any to read or copy part of source Shift F12 Exit without changes (useful if Editor get crazy...) }, width-12 title("Holding Ctrl") Report { Ctrl+X Cut Ctrl+C Copy (copy Html and Simple Text, Html has 
 if tabs exist in copied text)
	Ctrl+V Paste	Ctrl+A Select all
	Ctrl+Z Undo (unlimited, but we loose it if we press Esc to leave from editor)		Ctrl+Y Redo (unlimited too)
	}, width-12
title("Using TAB")	
Report {
	Shift+Tab Insert spaces not tab
		we can change the tab width using a commmand: Edit ! Number. We can set spaces as tab using Switches "-TAB"
	Tab  insert a tab in umarked text, apply indentation in marked text
	Tab + Shift remove indentation in marked text,  Insert spaces as tab if no leading tab exist
	}, width-12
title("Special Key Combinations")
Report {
	Ctrl+Shift Enter place Braces and a line inside with proper indentation
		We can mark text and place braces and indentation for all marked text
	Ctrl+Shift+Space insert a non break space
	Alt+Shift+Space insert a figure space
	Alt + 5 + 9 return ANSI 0x59 (;)  (we can give any number - the number is in decimal Unicode format)
	a Alt "+" 3 0 2 a give â (Combining Diacritical Mark 0x302)  - we can use Ins if no Number Keypad exist (lfor aptos)
		We can use  numbers above 0x10000 . Hold Alt and press Ins 1 0 4 3 7 on keypad or number keys and release Alt to get 𐐷
	Pairs:() {} "" []  we press the first and we get the other and cursor set inside them
		Also we can mark text and press one of above to place makred text inside
	}, width-12
Press()
Cls
title("PopUp Menu")
Report {
	Open with Shift+F10, Key Context Menu if exist, left mouse button in edit area, right mouse button in header area
	We can move the menu (stay open until lost focus)
	We can resize the menu to get bigger text (also this operation resize other interpreter forms)
	
	First line show line number, character position and can input a line number to move this line to center vertical as possible
	Cut
	Copy
	Paste
	Save and Exit
	Discard Changes
	Search up
	Search down
	Make same All
	Replace word
	Word Wrap
	Drag Enabled (by default drop is enabled, to allow drag operation we have to set this)
		(drag start when we give a double click inside marked text. By default for inside drop is a cut and paste procedure)
		(Shift/Ctrl works also)
	Color/Short Language
	Paragraph Mark (show hidden characters, we can edit in this mode)
	Word Count
	Help  (if we makred a word - just click on it- we get a form with information about it).
	Modules/Functions.
	Insert File  (this is a macro which insert a file as Base64 encoded in text, for a string variable).
	Load Resource (this is a macro which insert a binary file to a buffer type variable).
	}, width-12
title("View code without moving the cursor from position")
Report {
	We can scroll up or down using vertical scroll bar. Press left or right or up or down or an key to return to previous view
	Use F1 to change wrap (this also has no affect to cursor).
	Move some lines up or down holding down right mouse button. There is a timer which enable quick move.
	The same timer enabled when we click the top or bottom areas of the scroll bar control.
	}, width-12
title("View/Select code as you change the cursor from position")
Report {
	Use arrows, Home (change from position 1 to first non space  in row, each time we use it).
	End to end of line. Ctrl+PageUp to first line, Ctrl+Page Down to last line
	Page Up, Page Down  (Page is the  half page of view).
	Clicking with right mouse button.
	Shift with all above mark text.
	**New**	Ctrl+Left or Right arrow make long jump based on context, can be used with Shift to mark text also
			Ctrl+Delete, Ctrl+Backspace delete multiple characters base on the jump system.
	Using mouse wheel we change half pages (moving the cursor too), shift has no effect.
	Using F6 to F8 (Bookmarks) to jump to a bookmark.

	When we edit a line editor keep the line in the middle of view if it is possible.
	If no warp enabled then the horizontal moving is automated, when we type, or when we move text to drop it,
	depending of the position of the "running cursor" (if we miss the drop, the cursor return to starting position).
	}, width-12
Press()
cls, -2
Keyboard "infoBasic"+chr$(13)
End  ' we can omit this
Sub title(a$)
Pen #ffeeff {
	cursor 0
	Italic 1
	a$=replace$(chr$(9),"      ", a$)
	Report a$
	Italic 0
	cursor 6, row-1
}
End Sub
Sub Press()
	wait 200
	local col=15,  col2=backcolor, threadid
	Input End  ' empty buffer too
	Print @(0,Height);
	Thread {
		Pen col {
		Print Over $(3), "Press space bar or mouse key":Refresh
		}
		swap col, col2
	} as threadid interval 250
	Main.Task 10 {
		if keypress(1) or keypress(32) then exit
	rem		if mouse>0 or inkey$<>"" then exit
	}
	Threads Erase
End Sub
}
MODULE FORM44 {Module TryIt {
	Rem : Set slow
	Set fast
	// new for Concurrent, a value non zero cause maintask to not execute step by step
	Thread.Plan  Concurrent 1  ' Sequential
	Refresh 40
	SMOOTH on
	Cls,0
	\\ using ,0 we switch console to minimize state
	\\ any value else or no value restore to normal state
	title "Start Up" ', 0
	N=3
	\\ we choose to use automatic event object
	\\ this event object expect to find Form1() function
	\\ using automatic object we can't disable it
	\\ also events which expect changes to variables
	\\ bypass the stantard callback and resolve to a function
	\\ like  Form1.Unload() which get back the Nook value
	
	Declare Form1(N) Form
	
	\\ Buttons can be clicked or shifted right (same as clicked)
	
	Class Buttons { 
	      Dim Butt() 
	      Module SetCaption { With .Butt(Number), "Caption",Letter$}
	      Function ReadCaption$ { With .Butt(Number), "Caption" as Result$ : = Result$}
	}  
	Dim Controls(N)=Buttons()  \\ an array of arrays
	\\ 
	For i=0 to N-1 {
	      For Controls(i) {
	            \\ need to be a new name for array
	            \\ a For object { } delete any new name
	            \\ so each time this block run, starts with no Button1() array
	            \\ then make one, then we get a copy (and references to actual objects)
	            \\ and then Button1() erased
	            \\ but Controls(i).Butt() can't erased because exist before we enter the loop
	            Declare Button1(2) button Form Form1(i)
	            For j=0 To 1 {
	                  Method Button1(j), "move", 1000+4000*j, 2000,3000,1000
	                  if j=1 then {
	                        Method Button1(j), "curve",3
	                  } else Method Button1(j), "transparent"
	                 
	            }
	            .Butt()=Button1()
	      }
            With Form1(i), "TitleBarColor",#aaaa88, "TitleTextColor",14, "TitleIconColor",#eeeeee
            Method Form1(i), "TransparentTitle"
            Layer Form1(i) {
                Cls 4, 0
                Gradient 1,4
                Cursor 0,3
                Report 2, "Hello There"
            }
            Method Form1(i), "Show"
	}
	\\ check this. After 6 second we can unload two forms
	\\ Ttry to close anything. You can without a problem
	\\ and after 3 seconds one more
	\\ just press enter after Rem 1: to make lines ready for execution
	Rem 1: Wait 6000 : PrintAndRefresh("CloseNow") : For i=1 to 2 : Method Form1(i), "CloseNow" : Next i
	Rem 2: Wait 3000 : PrintAndRefresh("Unload") : Refresh  : Declare Form1() Nothing
	Rem 3: Show \\ get the focus back
	Rem 4: Print "ok" : Exit
	
	Form1_1=true
	Controls(1).SetCaption 0, "Click Me"
	Controls(1).SetCaption 1, "ok"
	Controls(2).SetCaption 1, "Test Me"
	\\ we make a variable bound to a property
	With form1(0), "Visible" As visible
	CloseThisForm=0
	CloseThisTitle$=""
	closeme=false
	Function CloseAfter {
	
	      If Ask("Close Form?", CloseThisTitle$)=1 Then {
	      If CloseThisForm=1 Then Form1_1=false
	      Method Form1(CloseThisForm), "CloseNow"
	      }
	      closeme=false
	}
	Function Form1.Unload {
		if closeme then exit sub
	      Read New index, &Nook
	      Nook=True  \\ no unload now
	      \\ After make an unamed thread
	      \\ we use this of async waiting for user to
	      \\ provide feedback from a message box
	      with Form1(index), "title" as title$
	      CloseThisTitle$=title$
	      CloseThisForm=Index
 	      closeme=true
	}
	Function Button1.Click {
	      Read New K, L
	      Print "Form:";L,"Button:";K
	      Print Controls(L).ReadCaption$(K)
	      if k=1 and l=2 then after 20 {test}
	}
	Function Form1.MouseMove {
	      Read New K, Button, Shft, X, Y
	      If Button=1 Then {
	           Layer Form1(K) {    
	                  move X, Y
	                  circle 500, 1, 14-K
	            }
	      }
	}
	Function Form1.MouseDown {
	      Read New K, Button, Shft, X, Y
	      If Button=2 Then {
	            Method Form1(K), "Control", 1 As UserControl
	            \\ we have to use new names if we "call local" a function
	            With UserControl, "Visible" As uVisible
	            uVisible=Not uVisible  \\ we can't use X~ as X = Not X     
	      }
	}
	'goto aaa
	boolean mine=false
	For i=0 to N-1 {
	\\ Threads get current layer as starting layer
	      Layer Form1(i) {
	            \\ so we make the thread inside Form Layer 
	            Thread {
	            part {
	                  If Form1_1 Then {    
	                              if not scale.x then  thread this erase
	                            \\ third parameter is for color, we can use Color(r,g,b) or Colour(r,g,b) 
	                            \\ for rgb value, or we can give an Html number like #FF0000	                            \\ another way is by using hex 0X80000012 for system colors
	                            \\ Here we use values from the range 0 to 15 (here from 7 to 15)
	                            \\ and these are the standard colors.
	                           Draw To Random(Scale.x), Random(Scale.y), Random(7,15)
	                           \\ sub PrintAndRefresh can be run because all threads are in the same module
	                           \\ Threads have their execution object and an object to draw, here the form1
	                           \\ When thread call sub, sub run on same execution object.
	                           \\ modules and functions have own execution object
	                           \\ so subs are light and interest because the see every variable as local
	                           \\ but we can make temporary anything
	                           \\ we can also create threads in a sub, without erase them. 
	                           \\ Threads erased when parent object erased, or when we send erase command
	                           \\ or when we exit Task.Main
	                           \\ for the situation of a thread created on a thread we can use Threads Erase
	                           \\ too remove all, including these. This we need it because, the second level of thread may
	                           \\ end after the erasing of module, where we create it, so can run code with variables which
	                           \\ are cleared. So With Threads Erase before exit module we are sure that Threading Pool is empty.
	                           \\ But this in not an every day situation.
	                           \\  (an after {}  thread creation in a thread execution is an example for a second level thread)
	                           Rem 100 :
	                          If random(100)<4 then  PrintAndRefresh("draw lines")
	                          refresh
	                  } Else Thread This Erase
	                  } as mine
	            } As OneMore   Interval 30
	            thread OneMore  execute  static me=i
	            \\ OneMore is a handler, so we lost first and second handler
	            \\ but we dont care, we close thread inside using This
	            \\ or we can let the Main Task erase it at the exit 
	      }
	}
	
	Thread {     
	      PrintAndRefresh(Str$(Now,"hh:mm:ss"))
	} As Inform Interval 1000
	\\ Inform is the Thread Handler, we don't use it here
	aaa:
	\\ Need a thread to run a Main.Task
	thread {
		threads: refresh
	} as showthreads interval 200
	Main.Task 100 {
	'Every 100 {
	      \\ using property  \\ 
	            Rem 1 :       Print Type$(Visible), Type$(Form1_1)
	            If Not visible Then break
	            if closeme  then Call Local CloseAfter()
	}
	
	\\  Cleaning;
	\\ A control has two objects, one in form (a UserControl, one type for all),
	\\ and the other is the wrapper, which serve as an event publisher,
	\\ and we can use propertiers and methods
	\\ When a Form unloaded not only erase UserControls but becaue hold referencse to wrappers
	\\ send deconstruct command to each one, to break any reference to form
	\\ and  erase internal collection - just throw references to actual objects
	\\ So our last references to wrappers are in Controls(i)
	\\ We can let M2000 to destroy the arrays, so the referecses, or we can do the job
	\\ and we can reuse it
	\\ so we check this with a jump to there
	Goto there
	For i=0 to N-1 {
	      For Controls(i) {
	            Dim .Butt()
	      }
	}
	there:
	\\ this command unload forms
	Declare Form1() Nothing
	'title "End"
	'Show
	Threads Erase
	Smooth off
	Thread.Plan Sequential  ' set the default again (can be set if no thread exist)
	Refresh 30
	Sub PrintAndRefresh(A$)
	            Print A$
	            Refresh
	End Sub
}
While inkey$<>"" {}
Cls ,0
Report {Form44
You can:
      1. draw on Windows using right mouse button.
      2. slide or click a button to see the response in console.
      3. hide title using left mouse button.
      4. click on Test button on Window 2, to open test dialog.
      5. move the windows
      6. Use Shif + F4 to close a form (even with hidden title)
      
      Closing form 2 stop threads for line drawing.
      Closing form 1 close all forms, program exit
      
      Enjoy
      George Karras
      
      (press any key)

}
push key$ : drop
TryIt
test !
if module(infobasic) then keyboard "infobasic", 13
}
MODULE LIST33 {Declare Simple Form
With Simple, "Title" As myTitle$
\\ make window, not show yet
Layer Simple {
      Linespace 60
      Font "Arial Black"
      Window 16, 8000,6000
      gradient 11, 1, 0
      Cursor 0, height div 2
      Report 2,"Hello World"
}
\\ now put a ListBox
Declare Listbox1 Listbox Form Simple
Method Listbox1, "move", 1000,1000,6000,4200
//Method Listbox1, "SetBarStyle", 11
Method Listbox1, "SetBarStyle", color(50, 100,  200), 3
\\ and fill with some data
With ListBox1,"Text",{London
                                    Paris
                                    Athens
                                    Rome
                                    Tirana
                                    Nicosia
                                    Brussels
                                    Copenhagen
                                    Berlin
                                    Dublin
                                    Luxembourg
                                    London2
                                    Paris2
                                    Athens2
                                    Rome2
                                    Tirana2
                                    Nicosia2
                                    Brussels2
                                    Copenhagen2
                                    Berlin2
                                    Dublin2
                                    Luxembourg2
                                    }
\\ and set some properties, and some of them are bind to objects that are properties to objects.
\\ also when we call a method, internal a resolved done in first time, so next time a method call will be faster.
With Listbox1, "transparent", True , "ListIndex" As ListIndex, "ListCount" As  ListCount
With Listbox1, "Find" As Find(),  "List" As List$(), "maychange", true
\\ make simple sizable form (units for forms are in twips)
With Simple,"Sizable", True,"SizerWidth",90
\\ now these are the event handlers
\\ event handlers can see anything defined in parent module
\\ for this reason for &rgb we need a Read New (so a new rgb prepared before a reference assign to it)
\\ any variable can get a reference to other variable once, at defining stage.
Inventory Blocked= "Rome", "Rome2", "Berlin"
Function Simple.Unload {
      Keyboard "!"   \\ like press !
}
Function listbox1.Color {
      Read New &rgb
            rgb=#FF7700
}
Function listbox1.Sep {
      Read New &D
		if exist(Blocked, List$(d)) then d=-1
		
}
Function Listbox1.DblClick {
            Read Where 
            if Right$(List$(Where),1)="✓" then {
                  List$(Where)=leftPart$(List$(Where)+" "," ")
            } else {
                  List$(Where)=leftPart$(List$(Where)+" "," ")+" ✓"
            }
            Mytitle$= List$(Where) 
'            Method Simple,"RefreshAll"
            Method Listbox1,"Refresh"

}
Function simple.click {
            If ListIndex>=0 Then {
                  local K$=List$(ListIndex), i
                  Method listbox1,"Sort"
                  ListIndex=Find(K$)
                  Layer {
                        \\ we print to standard cosnole layer
                        Print ">>", control$
                  }
            } Else Method Listbox1,"Sort"
}
Function Simple.Resize {
      Layer Simple {
            Mode 16
	     gradient 11, 1, 0
            Cursor 0, height div 2
            Report 2,"Hello World"
            Method Listbox1,"Refresh"
      }
      \\ we put a refresh to console because
      \\ when this handler run, can't run thread k.
      Layer { Refresh}
      Method Simple, "refreshALL"
}
\\ now we want to show (without modal showing)
Method Simple, "TransparentTitle"
Method Simple, "Show"
\\ We can put a background task (a thread), triggering each 100 mSec
Thread {
      Print tick  \\ tick is thread manager timer
      refresh
} as K interval 100
a$=Key$ \\ no loop just wait a key, in console only
Threads Erase
Declare Simple Nothing
}
MODULE TEXTOUT {Module UsingEvents {
      rem Form ! 80,66
      \\ from version 9.9 we have to get the byvalue parameters to variables without & (which used for byref read)
      Declare WithEvents sp "SAPI.SpVoice"
      That$={Rosetta Code is a programming chrestomathy site.
      The idea is to present solutions to the same task in as many different languages as possible, to demonstrate how languages are similar and different, and to aid a person with a grounding in one approach to a problem in learning another. Rosetta Code currently has 913 tasks, 214 draft tasks, and is aware of 707 languages, though we do not (and cannot) have solutions to every task in every language.}
      EndStream=False
      LastPosition=-1
      TxtWidth=0
      Function sp_Word {
            Read New StreamNumber, StreamPosition, CharacterPosition, Length
            Rem:  Print StreamNumber, StreamPosition , CharacterPosition, Length
            If  LastPosition=CharacterPosition Then exit
            LastPosition=CharacterPosition
            Local f$=" "
            If TxtWidth=CharacterPosition+length Then f$=". "
            If length+pos+2>width then Print
            Print Mid$(That$, CharacterPosition+1, Length);f$;
            If f$=". " Then Print
            Refresh
      }
      Function sp_EndStream {
            Refresh
            EndStream=True
      }
      Function sp_Sentence {
            Read New StreamNumber, StreamPosition, CharacterPosition, Length
            if Length>0 and not CharacterPosition=0 then Print
            Print "  ";
            TxtWidth=CharacterPosition+Length-1
      }
      Const  SVEEndInputStream = 4
      Const  SVEWordBoundary = 32
      Const  SVESentenceBoundary = 128
      Const SVSFlagsAsync = 1&
 
      With sp, "EventInterests", SVEWordBoundary+SVEEndInputStream+SVESentenceBoundary
      Method sp, "Speak", That$, SVSFlagsAsync
      While Not EndStream {Wait 10}
      Wait 100
}
oldVolume=Volume
Volume 100
UsingEvents
Volume oldVolume
}
MODULE MOVEBUTTON {Declare Form1 Form
Declare Button1 Button Form Form1
Declare TextBox1 TextBox Form Form1
Bx=4
Layer Form1 {
      Linespace 0
      Window 8, 10000, 6000
      Cls 1,0
      Form 30, 10
      Print @(0,4),"123456789012345678901234567890"
      Cursor Bx, 5
      Move !
      Button1_Xpos=Pos.x
      Button1_Ypos=Pos.y
      Xt=Button1_Xpos div Bx
      Yt=Button1_Ypos div 5
}
Method Textbox1,"Move", 1000,1000, 6000,600
Method Button1,"Move", Button1_Xpos, Button1_Ypos, Xt*5, Yt*2
Method Button1,"Curve",1 \\ 2 - 3 (single float)
Method Form1, "Show"
Function Form1.Unload {
      Keyboard "!"
}
Function Button1.Click {
      \\ print to console
      layer Form1 {            
            motion.w 0 ;
            
      }
      Print "Hello"
}
Function Form1.MouseDown {
      Drop 2 ' no need now (keycode and shift)
      Read New X, Y
      Layer Form1 {
            Move X, Y
            Cursor ! \\ transform to char coordinates
            Move ! \\ transform to graphic, at the up left corner of a char
            Method Button1,"Move", Pos.x, Pos.y
      }
}

A$=key$
Declare Button1 Nothing
Declare Form1 Nothing
}
MODULE DR {Module RomanNumbers {
      flush  ' empty current stack
      gosub Initialize
      document Doc$
      while not empty
            read rom$
            print rom$;"=";RomanEval$(rom$)
            Doc$=rom$+"="+RomanEval$(rom$)+{
            }
      end while
      Clipboard Doc$
      end
Initialize:
      function RomanEval$(rom$) {
            Flush
            ="invalid"
            if filter$(rom$,"MDCLXVI")<>"" Then Exit
            \\ "Y" is in top of stack
            Push "CM", "MD", "Q"
            Push "CD", "MD","W"
            Push "XC", "DL", "E"
            Push "XL", "X","R"
            Push "IX","V","T"
            Push  "IV","I","Y"
            \\ stack flush to doublerom
            doublerom=[]
            \\  "M" is in top of stack
            Data "M", 1000, "Q",900
            Data "D", 500,"W", 400
            Data "C",100,"E",90
            Data "L",50,"R", 40
            Data "X", 10, "T", 9
            Data "V", 5, "Y", 4, "I",1
            \\ stack flush to singlerom
            singlerom=[]
            acc=0
            value=0
            count=0
            stack doublerom {
                  if empty then exit
                  read rep$,exclude$,cc$
                  i=instr(rom$,cc$)
                  if i >0 then
                        tmp$=mid$(rom$,i+2)
                        L=Len(tmp$)
                        if L>0 then if Len(filter$(tmp$, exclude$))<>L then rom$="A": exit
                        if Instr(rom$,mid$(rom$,i,1))3 then exit
                  loop
            }
            if len(rom$)>0  or count>3 Else
                  =Str$(acc,1033)
            end if      
      }
      data "MMMCMXCIX", "LXXIIX", "MMXVII", "LXXIX", "CXCIX","MCMXCIX","MMMDCCCLXXXVIII"
      data "CMXI","M","MCDXLIV","CCCC","IXV", "XLIXL","LXXIIX","IVM"
      data "XXXIX", "XXXX", "XIXX","IVI", "XLIX","XCIX","XCIV","XLVIII"
      return
}
RomanNumbers
}
MODULE G1 {t=0
{
'loop
t++
on t goto 100, 101

end
Print 0100
Print "fault"
0100 Print "ok1"
Restart
10100 Print "ok2"
exit
101 Print "ok"
}
}
MODULE G2 {goto 100

end
Print 0100
Print "fault"
0100 Print "ok1"
}
MODULE G3 {goto 100

end
Print 100
Print "fault"
100 Print "ok1"
}
MODULE G11 {t=0
again:
t++
on t goto 100, alfa
end
Print 0100
Print "fault"
0100 Print "ok1" : Print "100"
goto again
10100 Print "fault"
exit
alfa:
101 Print "ok2", t

}
MODULE G12 {alfa:
101  static a=10
110 a--
120 print a
130 if a>1 then goto alfa
140 Clear
}
MODULE G4 {Module beta {
      print "i am beta"    
}
X=4
beta: Print "ok"  \\ call beta then print ok
beta: \\ only rem
Print x
x--
If x<1 Else Goto beta
k=false
x=100

}
MODULE M2 {a=(1,2,3,4,5)
fold1=lambda (a, b)-> {
      push a+b
}
fold2=lambda (a, b$) -> {
      if len(b$) Then {push b$+","+str$(a,"")} else push str$(a,"")
}
'? a#fold(fold1, 0)=a#sum()
odd=lambda (x) ->x mod 2=1
even=lambda (x)->x mod 2=0
add2=lambda (x)-> {
      push x+2
}
square=lambda (x)-> {
      push x*x
}
combine=lambda  -> {
      a=Array([])
      if len(a)=0 then =lambda->{} : exit
      =lambda  a ->{
            for i=0 to len(A)-1 { 
                  m=array(a,i)
                  call m()
            }
      }
}
? "["+a#filter(odd)#fold$(fold2, "")+"]"
? "["+a#filter(even)#map(add2)#fold$(fold2, "")+"]"
a=(,)
z=a#filter(even,(0,))#map(add2)
Print z, type$(z)
a=(1,2,3,4,5)
? a#map(add2, square)
? "["+a#map(add2, square)#fold$(fold2, "")+"]"
}
MODULE FS2 {Form ! 60,40
linespace twipsY*4
Form ! 60
refresh
\\ using M2000 commands
Menu   ' clear Menu list
Files !  + "gsb|txt"   ' ! sorted by name, + add to menu
Print Len(menu$())

a=menu$()

\\ we can use Print a
\\ but get refresh after the last item
\\ so we can use code to diplay names in columns (expand if name is bigger for one column)
k=each(a)
mp=width/tab
mc=mp*height*3/5
m=mc
Print $(6, 15)  ' use numbers from 0 to 9  - colum width 15
While k {
	Print array$(k),
	m--
	if pos>=width then m--
	if m {
	=Var(0,a$)
}
VecOff=Lambda Var, VecType (a$, b$) -> {
	=Var(0, a$, VecType(b$)!)
}
Class cLine {
	X1, Y1, X2, Y2, color
	Module Render {
		' read Number from stack
		z=Round(Number,4)
		z1=Round(Number, 4)
		If z>=z1 Then {
			Move .X1, .Y1
			Width 3 {Draw to .X2, .Y2, .color}
			Circle Fill #aa33cc, z/40+200
		} Else {
			Move .X2, .Y2
			Circle Fill #aa33cc, z/40+200
			Width 3 {Draw to .X1, .Y1, .color}
		}
	}
Class:
	Module cLine (.color){
		If Match("NNNN") Then Read .X1, .Y1, .X2, .Y2
	}
}

\\ find address
vBase=VecAdr("vBase")
vBase.x=VecOff("vBase","x")
vBase.y=VecOff("vBase","y")
vBase.z=VecOff("vBase","z")
vRot1=VecAdr("vRot1")
vRot1.x=VecOff("vRot1","x")
vRot1.y=VecOff("vRot1","y")
vRot1.z=VecOff("vRot1","z")
vRot2=VecAdr("vRot2")
vRot2.x=VecOff("vRot2","x")
vRot2.y=VecOff("vRot2","y")
vRot2.z=VecOff("vRot2","z")
vRot3=VecAdr("vRot3")
vRot3.x=VecOff("vRot3","x")
vRot3.y=VecOff("vRot3","y")
vRot3.z=VecOff("vRot3","z")
vRot4=VecAdr("vRot4")
vRot4.x=VecOff("vRot4","x")
vRot4.y=VecOff("vRot4","y")
vRot4.z=VecOff("vRot4","z")
vAxis=VecAdr("vAxis")
Refresh 100
Declare Alfa Form
With Alfa, "Title", "Demo1", "UseIcon", True, "UseReverse", True  ' icon now is in the left side
Method Alfa,"MakeStandardInfo", 1   ' 1 for English
Def  info$, AskRet
OpenInfo=False
Function Alfa.InfoClick {
	Read New X
	If X=0 then
		OpenInfo=True
	end if
}
\\ a string to hold static background
screen$=""
disp=False
Inventory Depth
aLine=Each(Depth)
once=False
Function DepthSort() {
	Inventory Queue Depth ' clear Depth, Then make keys As numbers
	Append Depth, Eval(Var, vRot1.z As double):=1, Eval(Var, vRot2.z As double):=2, Eval(Var, vRot3.z As double):=3
	Sort Depth As number
}
Thread {
	part {
		Method Math, "RotVectMult", 4, vRot1, vAxis, vRot1, dAngle  ' , bDegrees:=false  ' true by default
		Push Eval(Var, vBase.y As double), Eval(Var, vBase.x As double)
		\\ x is in top, y is after x
		Over 2, 2 \\  copy two times from second, so double two top
			Line1.X1=Eval(Var, vRot4.x As double)+Number
			Line2.X1=Line1.X1
			Line3.X1=Line1.X1
			
			Line1.Y1=Eval(Var, vRot4.y As double)+Number
			Line2.Y1=Line1.Y1
			Line3.Y1=Line1.Y1
			Over 2, 4 \\ now original 2 values copied 4 times
			Line1.X2 = Eval(Var, vRot1.x As double)+Number
			Line1.Y2 = Eval(Var, vRot1.y As double)+Number
			Line2.X2 = Eval(Var, vRot2.x As double)+Number
			Line2.Y2 = Eval(Var, vRot2.y As double)+Number
			Line3.X2 = Eval(Var, vRot3.x As double)+Number
			Line3.Y2 = Eval(Var, vRot3.y As double)+Number
			call local depthsort()
			counter1++
			if random(20)>1 then exit
			Method Math, "Vector", vAxis,.4 -.8*rnd, 1.6, .2-.3*rnd
			Method Math, "UnitVect", vAxis
	}  As once
} As Compute
dim All(1 to 3) as object  // new from Version 12
Layer Alfa {
	Window 12, 10000, 8000;
	Form 40, 20
	Line1=cline(#0000FF, scale.x/2, scale.y/2, scale.x/2, scale.y/2-2220 )
	Line2=cline(#FF0000, scale.x/2, scale.y/2, scale.x/2-2340, scale.y/2-60 )
	Line3=cline(#00FF00, scale.x/2, scale.y/2, scale.x/2-780, scale.y/2-1200 )
	All(1)->Line1
	All(2)->line2
	All(3)->line3
	Declare Math Math
	Method Math, "Vector", vBase,scale.x/2-1500, scale.y/2+1500, 1500 '  -1000
	Method Math, "Vector", vRot1, Line1.X2, Line1.Y2, -1000
	Method Math, "Vector", vRot2, Line2.X2, Line2.Y2, -1200
	Method Math, "Vector", vRot3, Line3.X2, Line3.Y2, 1700
	Method Math, "Vector", vRot4, Line1.X1, Line1.Y1, 0
	Method Math,  "VecDiffMult", 4, vRot1, vBase, vRot1
	Inventory Depth=Eval(Var, vRot1.z As double):=1, Eval(Var, vRot2.z As double):=2, Eval(Var, vRot3.z As double):=3
	Sort Depth As number
	Method Math, "Vector", vAxis, -.8, 1.6, .3
	Method Math, "UnitVect", vAxis
	Rad2Deg =Lambda pidivby180=pi/180 (RadAngle)->RadAngle / pidivby180
	// dAngle =pi/128   ' Rad - use the optionallast  parameter as false (bDegrees:=false)
	dAngle=6.5  ' Degrees
	Pen 0
	Cls 7
	Gradient 11, 13
	Move 0,0
	Cursor 0, Height-1
	Cls 7, Height-1
	hold
	//Copy scale.x, scale.y to screen$
	Cursor 0,Height
	together=False
	ok1=true
	Thread {
		{ok1~: if ok1 then tm=timecount
		}
	} as mm interval 1000/50
	tm=0
	Thread {
		static internal=1
		'Move 0,0
		'Copy 0,0 use screen$
		{
			release
			Print @(3,3); format$("{0:2:-7}",tm)
			Cursor 0,height-1
			Print Part $(5,Width/4), counter1, counter2,internal, $(7),Str$(Now , "hh:mm:ss" )
		}
		Part {
			Part {
				aLine=Each(Depth)
				push  Eval(Var, vRot4.z As double) : Over 1, 2
				while aline {
					pp=all(eval(aLine))
					pp=>render  Val(eval$(Depth, aLine^))
				}
				counter2++
			} As disp
			if not OpenInfo then Refresh 5000
		} As together
		internal++
		Profiler
	} As PlayThis
}
\\ we set variables outside threads
State=False
blinking=False
Thread {
	If state Then disp~
 } As blink
Thread blink Hold
ExitNow=False
Function Alfa.Unload {
	ExitNow=True
	threads erase
}
Function Alfa.Click {
	State~
	If State Then
		Thread compute Hold
		Thread blink interval 1000/4
		Thread blink Restart
		blinking=true
	Else
		disp=False
		If blinking Then Thread blink  Hold : blinking~
		Thread compute Restart
	End If
}
if IsWine then
	Thread PlayThis interval 1000/30
else
	Thread PlayThis interval 1000/Rate
end if  
Thread compute interval ComputeInterval
Wait 200
Method Alfa, "Show"
\\ Change Task.Main with Every
\\ Task.Main is a Thread
\\ ExitNow needed If we have Every in place of Task.Main
Task.Main TM {
	if not together  then if OpenInfo then showinfo()
	If ExitNow Then Exit
}
Threads Erase
Thread.plan sequential   ' to default plan
Wait 100  \ some delay here
Method Alfa, "CloseNow"
Declare Alfa Nothing
Declare Math Nothing
Print counter1, counter2
Title "Demo Complete"
Smooth off
Set Fast   ' return to normal
sub showinfo()
	OpenInfo=false
	refresh 10
	Info$={
		This is an example
		of  using MATH object
		(included in M2000 Interpreter)
		}
	AskRet=Ask(info$,"About Demo1","","")	
end sub
}
MODULE UPDATE {// if you can't run update, means that you get an error and the name of the module erased from the list where the we place a statement replacer
// the update clause is a statement for M2000, so when we load inform the update clause replace by this module
// we can call this module using @update  if we can't call by name update
// don't use this module, use the saveme module Press F1 in the  m2000 console.

beep
Title "Info"
dir appdir$
save info, {UseThis : InfoBasic : C1: ShowKeys : Pen 15 {Print "Press F3 now"}}
if isnum then {
	drop
	open "info.bck" for output as #N
	close #N
}
dir user
save info, {UseThis : InfoBasic : C1:  ShowKeys: Pen 15 {Print "Press F3 now"}}
}
MODULE BJ { Escape Off
 Flush  \\empty Stack, we use optional arguments in Modules
 NoPlayers=4
\\ Dealer get one hidden And one open Card
\\ Player's get two open cards, one at a time
\\ Options for Split and Double Down
\\ If Player has a BlackJack Then dealer play for 21, changing cards for other players/splits
\\ Standard Bet 100 credits.  Each player start with 10000 credits
MakeLayer()

Print $(4)
Inventory Suits = "♠":=0, "♥":=4, "♦":=4, "♣":=0 'suit -> color
Inventory Cards = "two":=2, "three":=3, "four":=4, "five":=5
Append Cards, "six":=6, "seven":=7, "eight":=8, "nine":=9
Append Cards, "ten":=10, "jack":=10, "queen":=10, "king":=10, "ace":=1
Global CardsView
\\ use <= to feed CardsView
Inventory CardsView <= 2, 3, 4, 5, 6, 7, 8, 9,10, "jack", "queen", "king","ace"

\\ We use Module because each module has own use of dots..
\\ And we call it inside a For Object {} And outside of it
DealerMoney=0
Module PrintCardOnly (k, Suits, Cards, x=0) {
          For k {
                Pen Suits(.suit!) {
                        Print Part @(10+x,row,15+x,row+1,#FFE4E1,0), Eval$(Suits, .suit)+" "+CardsView$(.card!)
                        Print
                   }
        }
}
' Using a Stack object
StackPack = Stack
Module AppendArray (N, A) {
      Stack N {Data !A}
}
Class OneCard {
      suit=-1, Card
Class:
     Module OneCard {
           \\ ? for optional reading
           read ? .suit, .card
     }
}
\\ 3X52 cards
Dim Pack(Len(Cards)*Len(Suits)*(NoPlayers+1)) \\ Not used here =OneCard()
Pen 14
Double
Pen 14 {Report 2, "BlackJack"}
Normal
Cls, 2
k=0
\\ fill cards to Pack()
For times=NoPlayers+1 To 1 {
      N=each(Suits)
      While N {
            M=each(Cards)
            While M {
                  Pack(k)=OneCard(N^, M^)
                  k++
            }
      }     
}
Layer 1 {
	Report 2, "Prepare Cards"
}
Rem : DisplayAll() ' in order
Suffle()
Rem : DisplayAll() ' at random positions
Print
' first cut for player
layer 1{
	Print "Make a Cut: 0-51:";
	Repeat {
	      N1=Random(0,51)
	      Try {
	            Input ! N1, 10
	      }
	      Stack StackPack {
	            Drop N1
	      }
	} Until N1>=0 And N1<=51
	Print N1
}
\\ used to pass the Dealer's hidden Card
Hidden=OneCard()
DealerHidden=OneCard()
Class PlayerJB {
      Class PlayerGame {
            \\ Class is a Group Factory - a function whuch return Group
            \\ Class Definition in a Group is local else is Global
            \\ until erased when Definition Holder exit or end (a Module/Function where we define a class)
            Playervalue, Bet
            \\ we can define groups using class like this If class constructor work without parammeters
            OneCard LastCard
            Class:
            \\ Class: means that this module exist only at construction stage
            Module PlayerGame {
                  ' This module as part of constructor
                  ' so has own Stack when called as constructor
                 Read .Playervalue, .Bet
                 If Not Empty Then Read .LastCard
            }
      }
      Inventory queue PlayerCards
      OneCard PlayerFaceUp2nd, SplitCard
      Bet=100, PlayerMoney
      Playervalue
      OldPlayerValues=Stack
      Done=false
Class:
      Module PlayerJb (.PlayerMoney) {}
}
Dim Base 1, Players(NoPlayers)=PlayerJB(10000)
Def Val$(x)=If$(x=-1 -> "Black Jack", Str$(x,""))
Card=OneCard()
Function ClearCards {
      Inventory queue ClearCards
      =ClearCards
}
Function PlayerHasNoBlackJack(HasTheDealer) {
      ' we get two parameters
      If Not HasTheDealer Then Exit ' the second parameter droped from Stack
      ' now we read 2nd
      Read k
      Def Range(X, X1, X2)=X>=X1 and X<=X2
      m=false
      If k.PlayerCards(0!).card=12 And Range(k.PlayerFaceUp2nd.card,8 ,11) Then m=m or true
      If k.PlayerFaceUp2nd.card=12 And Range(k.PlayerCards(0!).card,8 ,11) Then m=m or true
      =Not m
}
DealerRow=0
Repeat {
      layer 1 {cls}
      donecount=0
      For i=1 to NoPlayers {
            For Players(i) {
                  .SplitCard=OneCard()
                  .OldPlayerValues=Stack
                  If .done Then donecount++ :  Exit
                  If .PlayerMoney<.Bet Then {
                      Layer 1{
                          Print Format$("Player({0}), you run out of money...Bye Bye", i)
                      }
                        .done=true
                         donecount++
                  } Else {
                     Layer 1{
                           Print format$("Player({0}) Money:",i), .PlayerMoney
                              Print "Play Game ?(Y/N)"
                              If Key$ ~ "[NnΝν]" Then .done=true :  donecount++
                    }
                  }
            }
      }
      if donecount" " {}
      cls,2
      AllPlayers=NoPlayers
      BlackJack=false
      PlayersBurst=0
      Clear dealervalue
      DealerCards=ClearCards()
      For i=1 to NoPlayers {
            For Players(i) {
                  If .done Then AllPlayers-- : Exit
                  Clear .playervalue
                   .PlayerCards=ClearCards()
                  Print Format$("Player {0} Hand: 1st Card", i)
                  PlayerCard(&.playervalue, .PlayerCards)
            }
      }
      If AllPlayers=0 Then Print "No More Players" : Exit
      Print "Dealer Hand: 1st Card"
      DealerRow=row
      DealerCard(&dealervalue)
      cursor 0,2
      For i=1 to NoPlayers {
            If Not Players(i).done Then {
                  Print @(18),Format$("2nd Card", i)
                  For Players(i) {
                        NextCard()
                        .PlayerFaceUp2nd<=Card
                        PrintCardOnly Card, Suits, Cards, 18
                  }
            }
      }
      Print @(18), "2nd Card"
      NextCard()
      Print @(18), "Face Down Card"
      cls , row+1 
      DealerHidden=Card
      ' now If dealer face up Card is Ace or 10 or Figure can see If has a black jack
      N2=Cards(Card.card!)
      If N2=10 And Cards(DealerCards(0!).card!)=1 Then DealerBlackJack()
      If N2=1 And Cards(DealerCards(0!).card!)=10 Then DealerBlackJack()
      For i=1 to NoPlayers {
           If Not Players(i).done Then
                  If PlayerHasNoBlackJack(BlackJack, Players(i)) Then
                  cls, 2
                  For Players(i) {.PlayerMoney-=.Bet : DealerMoney+=.Bet} 
                  Exit
                  end If
                   For Players(i) {
                         Bet=.Bet
                         Again:
                              Print format$("Player {0} Play", i)
                              If .PlayerCards(0!).card=.PlayerFaceUp2nd.card Then {
                                    If .PlayerMoney<2*.Bet Then exit
                                    Print "Split Cards ?(Y/N)"
                                    If Key$ ~ "[NnΝν]" Then Exit
                                    AllPlayers++
                                    .SplitCard<=.PlayerFaceUp2nd
                                    NextCard()
                                    .PlayerFaceUp2nd<=Card
                                    Stack .OldPlayerValues {Push .PlayerGame(.playervalue, Bet)}
                              }
                              Print "Player Hand:"
                              Hidden=.PlayerFaceUp2nd : .PlayerFaceUp2nd<=OneCard()
                              PrintCardOnly .PlayerCards(0!), Suits, Cards ' show first Card
                              PlayHand(.PlayerCards,&.playervalue, False, False, .PlayerMoney)
                              ' first we get Bet
                              .PlayerMoney-=Bet
                              DealerMoney+=Bet
                              Print
                              If .playervalue>21 Then {
                                    PlayersBurst++
                                    Print "Dealer Win"
                              } else.if .playervalue=-1 Then {
                                    ' dealer has to play with player now
                                    PlayersBurst++
                                    Print Format$("Dealer play against Player({0})",i)
                                    PrintCardOnly DealerCards(0!), Suits, Cards
                                    Hidden=DealerHidden : DealerHidden=OneCard()
                                    \\ ? means undefined value
                                    PlayHand(DealerCards,&dealervalue, true, true, ?)
                                    If dealervalue<>21 Then {
                                            Print "Player Win", Bet*3/2 : .PlayerMoney+=Bet*5/2 ' one we get before
                                            DealerMoney-=Bet*5/2
                                    } Else {
                                          Print "Dealer Win"  
                                    }
                                    If PlayersBurst-1 Then {
                                    Card=If(Bet>.Bet -> .PlayerCards((Len(.PlayerCards)-1)!), OneCard())
                                    Stack .OldPlayerValues {Data .PlayerGame(.playervalue, Bet, Card) : Read NextGame}
                                    Bet=NextGame.Bet
                                    Drop .PlayerCards Len(.PlayerCards) ' erase all cards
                                    Append .PlayerCards, "Split":=.SplitCard
                                    '.playervalue=Cards(.SplitCard.Card!)  ' this is the same
                                    .playervalue=NextGame.playervalue
                                    NextCard()
                                    .PlayerFaceUp2nd<=Card
                                    .SplitCard.Suit=-1
                                    Goto Again
                              }
                        Card=If(Bet>.Bet -> .PlayerCards((Len(.PlayerCards)-1)!), OneCard())
                        Stack .OldPlayerValues {Data .PlayerGame(.playervalue, Bet, Card)}
                  }
           end If      
      }
      If PlayersBurst