<![CDATA[HMGforum.com]]> http://mail.hmgforum.com Smartfeed extension for phpBB <![CDATA[HMG General Help :: Trogan:Win32/Bearfoos.Aiml :: Author franco]]> 2024-10-12T00:45:45+00:00 2024-10-12T00:45:45+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7614&p=71373#p71373 Any thoughts.
I think I am going to remove anything to do with hmg from this computer and start new.
Don`t know what else to do.
Trogan:Win32/Bearfoos.Aiml
This ends up being in compiled exe.
Franco]]> Any thoughts.
I think I am going to remove anything to do with hmg from this computer and start new.
Don`t know what else to do.
Trogan:Win32/Bearfoos.Aiml
This ends up being in compiled exe.
Franco]]> <![CDATA[HMG General Help :: Re: Trogan:Win32/Bearfoos.Aiml :: Reply by serge_girard]]> 2024-10-12T07:09:06+00:00 2024-10-12T07:09:06+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7614&p=71374#p71374 <![CDATA[HMG General Help :: Re: Trogan:Win32/Bearfoos.Aiml :: Reply by franco]]> 2024-10-19T15:40:09+00:00 2024-10-19T15:40:09+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7614&p=71378#p71378 <![CDATA[HMG General Help :: How to encrypt with public key PEM? :: Author edk]]> 2024-10-24T10:17:28+00:00 2024-10-24T10:17:28+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71383#p71383 Does anyone know how to use hbssl (OpenSSL wrapper) to encrypt a file or string using a public key pem file?

I can do this using the openssl command, e.g.

Code: Select all

openssl.exe pkeyutl -encrypt -inkey PublicKeyFile.pem -pubin -in FileToBeEnctrypted.txt -out EncryptedFile.txt
but I would like to do it with native hbssl functions, if possible at all.]]> Does anyone know how to use hbssl (OpenSSL wrapper) to encrypt a file or string using a public key pem file?

I can do this using the openssl command, e.g.

Code: Select all

openssl.exe pkeyutl -encrypt -inkey PublicKeyFile.pem -pubin -in FileToBeEnctrypted.txt -out EncryptedFile.txt
but I would like to do it with native hbssl functions, if possible at all.]]> <![CDATA[HMG General Help :: Re: How to encrypt with public key PEM? :: Reply by martingz]]> 2024-10-25T16:41:55+00:00 2024-10-25T16:41:55+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71385#p71385
stringkey:=alltrim(empresas->key)//llave privada en pem
coutf8:=co//cadena original en utf8
PrivateKey := EVP_PKEY_NEW() //Creamos llave privada
keyPtr := PEM_READ_BIO_RSAPRIVATEKEY(bio :=BIO_new_mem_buf( stringkey ), alltrim(empresas->keypass) )//cargamos la llave privada con su contraseña
EVP_PKEY_ASSIGN_RSA(PrivateKey,keyPtr)//la asignamos para su evaluacion
ctx := EVP_MD_CTX_create() //creamos variable de evaluacion
EVP_MD_CTX_init( ctx ) //incializamos varibale de evaluacion
signed := "" //inicializamos variable del resultado de evaluacion
EVP_SignInit_ex(ctx, HB_EVP_MD_SHA256) //Establecemos el metodo de encriptacion
EVP_SignUpdate(ctx, coutf8) //Le mandamos el mensaje a encriptar
EVP_SignFinal(ctx, @signed, PrivateKey)//Evaluamos mensaje a encriptar,resultado,llaveprivada
sellodigital := HB_BASE64ENCODE(signed)//Codificamos el resultado en base 64
EVP_cleanup()//limpiamos variable

I hope it is useful to you

I look forward to any comments]]>
stringkey:=alltrim(empresas->key)//llave privada en pem
coutf8:=co//cadena original en utf8
PrivateKey := EVP_PKEY_NEW() //Creamos llave privada
keyPtr := PEM_READ_BIO_RSAPRIVATEKEY(bio :=BIO_new_mem_buf( stringkey ), alltrim(empresas->keypass) )//cargamos la llave privada con su contraseña
EVP_PKEY_ASSIGN_RSA(PrivateKey,keyPtr)//la asignamos para su evaluacion
ctx := EVP_MD_CTX_create() //creamos variable de evaluacion
EVP_MD_CTX_init( ctx ) //incializamos varibale de evaluacion
signed := "" //inicializamos variable del resultado de evaluacion
EVP_SignInit_ex(ctx, HB_EVP_MD_SHA256) //Establecemos el metodo de encriptacion
EVP_SignUpdate(ctx, coutf8) //Le mandamos el mensaje a encriptar
EVP_SignFinal(ctx, @signed, PrivateKey)//Evaluamos mensaje a encriptar,resultado,llaveprivada
sellodigital := HB_BASE64ENCODE(signed)//Codificamos el resultado en base 64
EVP_cleanup()//limpiamos variable

I hope it is useful to you

I look forward to any comments]]> <![CDATA[HMG General Help :: Re: How to encrypt with public key PEM? :: Reply by franco]]> 2024-10-25T17:02:07+00:00 2024-10-25T17:02:07+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71386#p71386 Could you not use memowrit().
I am know using this to write into my exe files from another exe file.
You can change exe files if you write into the right spots.

Mostly from things you have helped me with.
Thanks Edward]]> Could you not use memowrit().
I am know using this to write into my exe files from another exe file.
You can change exe files if you write into the right spots.

Mostly from things you have helped me with.
Thanks Edward]]> <![CDATA[HMG General Help :: Re: How to encrypt with public key PEM? :: Reply by edk]]> 2024-10-25T20:43:55+00:00 2024-10-25T20:43:55+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71387#p71387 Thanks for your example. From what I understand, you sign the string with a private key, you know the password for it.
@ martingz / @ franco
I have to encrypt the token with a public key, issued by the government. For this public key, of course, we do not know the password.
I found an example in C

Code: Select all

#include <openssl/pem.h>
#include <string>
...

bool EncryptString(const std::string& InStr /*plaintext*/, const std::string& InPublicKey /*path to public key pem file*/, std::string& OutString /*ciphertext*/) {
    
    // Load key
    FILE* f = fopen(InPublicKey.c_str(), "r");
    EVP_PKEY* pkey = PEM_read_PUBKEY(f, NULL, NULL, NULL);
    fclose(f);
    
    // Create/initialize context
    EVP_PKEY_CTX* ctx;
    ctx = EVP_PKEY_CTX_new(pkey, NULL);
    EVP_PKEY_encrypt_init(ctx);

    // Specify padding: default is PKCS#1 v1.5
    // EVP_PKEY_CTX_set_rsa_padding(ctx, RSA_PKCS1_OAEP_PADDING); // for OAEP with SHA1 for both digests

    // Encryption
    size_t ciphertextLen;
    EVP_PKEY_encrypt(ctx, NULL, &ciphertextLen, (const unsigned char*)InStr.c_str(), InStr.size());
    unsigned char* ciphertext = (unsigned char*)OPENSSL_malloc(ciphertextLen);
    EVP_PKEY_encrypt(ctx, ciphertext, &ciphertextLen, (const unsigned char*)InStr.c_str(), InStr.size());
    OutString.assign((char*)ciphertext, ciphertextLen);

    // Release memory
    EVP_PKEY_free(pkey);
    EVP_PKEY_CTX_free(ctx);
    OPENSSL_free(ciphertext);

    return true; // add exception/error handling
}
I tried to adapt it to HB but it returns errors of unknown functions: EVP_PKEY_encrypt_init(), EVP_PKEY_encrypt(), ...]]> Thanks for your example. From what I understand, you sign the string with a private key, you know the password for it.
@ martingz / @ franco
I have to encrypt the token with a public key, issued by the government. For this public key, of course, we do not know the password.
I found an example in C

Code: Select all

#include <openssl/pem.h>
#include <string>
...

bool EncryptString(const std::string& InStr /*plaintext*/, const std::string& InPublicKey /*path to public key pem file*/, std::string& OutString /*ciphertext*/) {
    
    // Load key
    FILE* f = fopen(InPublicKey.c_str(), "r");
    EVP_PKEY* pkey = PEM_read_PUBKEY(f, NULL, NULL, NULL);
    fclose(f);
    
    // Create/initialize context
    EVP_PKEY_CTX* ctx;
    ctx = EVP_PKEY_CTX_new(pkey, NULL);
    EVP_PKEY_encrypt_init(ctx);

    // Specify padding: default is PKCS#1 v1.5
    // EVP_PKEY_CTX_set_rsa_padding(ctx, RSA_PKCS1_OAEP_PADDING); // for OAEP with SHA1 for both digests

    // Encryption
    size_t ciphertextLen;
    EVP_PKEY_encrypt(ctx, NULL, &ciphertextLen, (const unsigned char*)InStr.c_str(), InStr.size());
    unsigned char* ciphertext = (unsigned char*)OPENSSL_malloc(ciphertextLen);
    EVP_PKEY_encrypt(ctx, ciphertext, &ciphertextLen, (const unsigned char*)InStr.c_str(), InStr.size());
    OutString.assign((char*)ciphertext, ciphertextLen);

    // Release memory
    EVP_PKEY_free(pkey);
    EVP_PKEY_CTX_free(ctx);
    OPENSSL_free(ciphertext);

    return true; // add exception/error handling
}
I tried to adapt it to HB but it returns errors of unknown functions: EVP_PKEY_encrypt_init(), EVP_PKEY_encrypt(), ...]]> <![CDATA[HMG General Help :: Re: How to encrypt with public key PEM? :: Reply by franco]]> 2024-10-26T16:30:37+00:00 2024-10-26T16:30:37+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71388#p71388 In my exe files. Once the customers serial number checks out in the files. I memowrit() the exe file from another exe file and
write the serial number into the main exe file in a allowable area which is where the file has text.
I use the spot where program says This program cannot be run in dos mode.
I think you can write at end of file also.
I use notepad++ to test. You can open and change exe files with ++. When it will not run I change it back until I can find an allowable area.
I am also taking the MZ from the front of the exe and replacing it with blanks. When things check out I replace the form other exe with.
var:=memoread('main.exe')
memowrit('main.exe','MZ'+substr(var,3,len(memvar)))
this works.
May be way off what you are looking for but could help someone else.]]> In my exe files. Once the customers serial number checks out in the files. I memowrit() the exe file from another exe file and
write the serial number into the main exe file in a allowable area which is where the file has text.
I use the spot where program says This program cannot be run in dos mode.
I think you can write at end of file also.
I use notepad++ to test. You can open and change exe files with ++. When it will not run I change it back until I can find an allowable area.
I am also taking the MZ from the front of the exe and replacing it with blanks. When things check out I replace the form other exe with.
var:=memoread('main.exe')
memowrit('main.exe','MZ'+substr(var,3,len(memvar)))
this works.
May be way off what you are looking for but could help someone else.]]> <![CDATA[HMG General Help :: Re: How to encrypt with public key PEM? :: Reply by edk]]> 2024-10-26T22:27:52+00:00 2024-10-26T22:27:52+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7617&p=71389#p71389
Here's an lesson of encrypting communication over the Internet: https://www.khanacademy.org/computing/c ... encryption

I have a public key and content (plain text) to encode. I need to do Step 3, which is encode the content with the public key. I can do this using openssl.exe, but I wanted to do it using hbssl.

I'm on the right track, but it requires recompiling the latest hbssl libraries with openssl.]]>
Here's an lesson of encrypting communication over the Internet: https://www.khanacademy.org/computing/c ... encryption

I have a public key and content (plain text) to encode. I need to do Step 3, which is encode the content with the public key. I can do this using openssl.exe, but I wanted to do it using hbssl.

I'm on the right track, but it requires recompiling the latest hbssl libraries with openssl.]]> <![CDATA[HMG General Help :: PEPPOL :: Author serge_girard]]> 2024-11-05T19:40:18+00:00 2024-11-05T19:40:18+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7619&p=71394#p71394
Anybody busy with PEPPOL?

Introduction to openPeppol and BIS
This Peppol BIS provides a set of specifications for implementing a Peppol business process.

This specification, is a Core Invoice Usage Specification (CIUS) of EN 16931, following the guidance given in chapter 7 of the EN 16931. Any instance documents compliant to this specification will be compliant with the European Standard (EN 16931).

From 1-1-2026 it will be mandatory to use this system in order to exchange/send invoices. I now send invoices in PDF via e-mail and this will be forbidden from this date...

So if anybody has experience...

Greetings, Serge]]>
Anybody busy with PEPPOL?

Introduction to openPeppol and BIS
This Peppol BIS provides a set of specifications for implementing a Peppol business process.

This specification, is a Core Invoice Usage Specification (CIUS) of EN 16931, following the guidance given in chapter 7 of the EN 16931. Any instance documents compliant to this specification will be compliant with the European Standard (EN 16931).

From 1-1-2026 it will be mandatory to use this system in order to exchange/send invoices. I now send invoices in PDF via e-mail and this will be forbidden from this date...

So if anybody has experience...

Greetings, Serge]]> <![CDATA[HMG General Help :: Re: PEPPOL :: Reply by edk]]> 2024-11-05T21:24:19+00:00 2024-11-05T21:24:19+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7619&p=71395#p71395 From what I know, to connect to the PEPPOL network, companies need to use a PEPPOL access point, usually from an external service provider such as Data Interchange. As the name suggests, access points act as a gateway to the PEPPOL network, allowing electronic documents to be sent and received to/from other organizations that are connected to the access point. So, you need to use the services of one of the available EDI (Electronic Data Interchange) providers that is connected to the PEPPOL network. In my case, this is Comarch, with whom I exchange invoices using xml files (each EDI provider may have its own specifications). It is the EDI provider's job to transform this data into PEPPOL. Such a document is sent to the EDI provider of the e-invoice recipient and this provider transforms the data into a data format agreed with the recipient.

Sender --> Sender EDI Provider (PEPPOL Access Point) --> PEPPOL NETWORK --> Recipient EDI Provider (PEPPOL Access Point) --> Recipient]]> From what I know, to connect to the PEPPOL network, companies need to use a PEPPOL access point, usually from an external service provider such as Data Interchange. As the name suggests, access points act as a gateway to the PEPPOL network, allowing electronic documents to be sent and received to/from other organizations that are connected to the access point. So, you need to use the services of one of the available EDI (Electronic Data Interchange) providers that is connected to the PEPPOL network. In my case, this is Comarch, with whom I exchange invoices using xml files (each EDI provider may have its own specifications). It is the EDI provider's job to transform this data into PEPPOL. Such a document is sent to the EDI provider of the e-invoice recipient and this provider transforms the data into a data format agreed with the recipient.

Sender --> Sender EDI Provider (PEPPOL Access Point) --> PEPPOL NETWORK --> Recipient EDI Provider (PEPPOL Access Point) --> Recipient]]> <![CDATA[HMG General Help :: Re: PEPPOL :: Reply by serge_girard]]> 2024-11-06T08:02:30+00:00 2024-11-06T08:02:30+00:00 http://mail.hmgforum.com/viewtopic.php?f=5&t=7619&p=71397#p71397
Serge]]>
Serge]]> <![CDATA[General :: HMG 3.5 :: Author jorge.posadas]]> 2024-10-11T21:47:13+00:00 2024-10-11T21:47:13+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7613&p=71372#p71372
Alguien me puede pasar la liga para bajar la ultima version de HMG 3.5, por favor, estoy usando la version 3.6 (64b) pero cuando hago una pequeña aplicación para usar MariaDB me manda un error y esa aplicación nunca me dio error con la versión 3.5.
Es por eso que necesito instalar la 3.5

De antemano agradezco la atencion a la presente]]>
Alguien me puede pasar la liga para bajar la ultima version de HMG 3.5, por favor, estoy usando la version 3.6 (64b) pero cuando hago una pequeña aplicación para usar MariaDB me manda un error y esa aplicación nunca me dio error con la versión 3.5.
Es por eso que necesito instalar la 3.5

De antemano agradezco la atencion a la presente]]> <![CDATA[General :: Re: HMG 3.5 :: Reply by ASESORMIX]]> 2024-10-16T11:24:33+00:00 2024-10-16T11:24:33+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7613&p=71375#p71375 Describe el error dado.]]> Describe el error dado.]]> <![CDATA[General :: Re: HMG 3.5 :: Reply by edk]]> 2024-10-16T14:45:17+00:00 2024-10-16T14:45:17+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7613&p=71376#p71376 https://linguagemclipper.com.br/system/ ... _setup.exe]]> https://linguagemclipper.com.br/system/ ... _setup.exe]]> <![CDATA[General :: Re: HMG 3.5 :: Reply by jorge.posadas]]> 2024-10-16T19:45:40+00:00 2024-10-16T19:45:40+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7613&p=71377#p71377 <![CDATA[General :: Re: HMG 3.5 :: Reply by ASESORMIX]]> 2024-10-19T19:13:44+00:00 2024-10-19T19:13:44+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7613&p=71379#p71379 what can we do with this?
https://www.kresin.ru/en/llama_prg.html]]> what can we do with this?
https://www.kresin.ru/en/llama_prg.html]]> <![CDATA[General :: Re: Imagen persiste al final :: Reply by LOUIS]]> 2024-10-19T23:22:30+00:00 2024-10-19T23:22:30+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7606&p=71380#p71380
I want to apologize because I couldn't incorporate your code into my project.

En realidad el rebote fue fabuloso ver cómo funciona, pero en mi caso, creo que es necesario dirigir sólo un rebote hacia arriba, pero no pude dirigirlo hacia un punto específico del screen, como por ej 0,350 o 0,500 partiendo desde un punto específico.
Luego la caída también debe ser dirigida de acuerdo a la Distancia, es decir necesito manejar Ángulo y Distancia, tanto de subida como de bajada.
Quizás no logré adaptar tu código, debido a que ya he explicado varias veces no soy un profesional de la programación, sin embargo fui autodidacta y me gusta y me entusiasma mucho este mundo, es más te cuento que el programa anterior de la culebrita, no logré entender cuando colisionaba con la cola, sin embargo seguí buscando la forma de hacerlo y use una dbf para llevar el control, y lo hice :)

El juego que esta ocasión trato de actualizar (ah, por cierto muy chévere el Arkanoid, yo también lo jugué), es el de los Gorilas, hecho bajo Qbasic en los 90, adjuntaré el código original por si lo quieren revisar.

Estuve ausente unos días, porque me he estado rompiendo la cabeza y bueno, aún tengo unas dificultades como la dirección del ataque en sentido derecha-izquierda, sería interesante que al sentir la bomba disparada y al dar al objetivo, sienta que ese lugar está ocupado por el objetivo y estallar.

Deben haber hasta 6 juegos, donde los gorilas aparecen encima de los edificios del 1 al 6 (el gorila del lado izquierdo) y del 8 al 13 (el gorila del lado derecho) ... voy por el # 1 :oops: porque hay que pulir bien las situaciones del primer juego, luego los demás se añaden más fácil supongo.

Creo que será un jueguito muy simpático para todos, pero hay que meterle mano y ayudarme, porque sino, no sé cuándo terminaré :cry:

Estimado Edward, perdón porque tuve que seguir usando la imagen tapada, usando ahora release en vez de hide, creo funciona mejor.

Saludos a todos
Louis

Este es el código original ...

Code: Select all

'                         Q B a s i c   G o r i l l a s
'
'                      Copyright (C) IBM Corporation 1991
'
' Your mission is to hit your opponent with the exploding banana
' by varying the angle and power of your throw, taking into account
' wind speed, gravity, and the city skyline.
'
' Speed of this game is determined by the constant SPEEDCONST.  If the
' program is too slow or too fast adjust the "CONST SPEEDCONST = 500" line
' below.  The larger the number the faster the game will go.
'
' To run this game, press Shift+F5.
'
' To exit QBasic, press Alt, F, X.
'
' To get help on a BASIC keyword, move the cursor to the keyword and press
' F1 or click the right mouse button.
'

'Set default data type to integer for faster game play
DEFINT A-Z

'Sub Declarations
DECLARE SUB DoSun (Mouth)
DECLARE SUB SetScreen ()
DECLARE SUB EndGame ()
DECLARE SUB Center (Row, Text$)
DECLARE SUB Intro ()
DECLARE SUB SparklePause ()
DECLARE SUB GetInputs (Player1$, Player2$, NumGames)
DECLARE SUB PlayGame (Player1$, Player2$, NumGames)
DECLARE SUB DoExplosion (x#, y#)
DECLARE SUB MakeCityScape (BCoor() AS ANY)
DECLARE SUB PlaceGorillas (BCoor() AS ANY)
DECLARE SUB UpdateScores (Record(), PlayerNum, Results)
DECLARE SUB DrawGorilla (x, y, arms)
DECLARE SUB GorillaIntro (Player1$, Player2$)
DECLARE SUB Rest (t#)
DECLARE SUB VictoryDance (Player)
DECLARE SUB ClearGorillas ()
DECLARE SUB DrawBan (xc#, yc#, r, bc)
DECLARE FUNCTION Scl (n!)
DECLARE FUNCTION GetNum# (Row, Col)
DECLARE FUNCTION DoShot (PlayerNum, x, y)
DECLARE FUNCTION ExplodeGorilla (x#, y#)
DECLARE FUNCTION Getn# (Row, Col)
DECLARE FUNCTION PlotShot (StartX, StartY, Angle#, Velocity, PlayerNum)
DECLARE FUNCTION CalcDelay! ()

'Make all arrays Dynamic
'$DYNAMIC

'User-Defined TYPEs
TYPE XYPoint
  XCoor AS INTEGER
  YCoor AS INTEGER
END TYPE

'Constants
CONST SPEEDCONST = 2500
CONST TRUE = -1
CONST FALSE = NOT TRUE
CONST HITSELF = 1
CONST BACKATTR = 0
CONST OBJECTCOLOR = 1
CONST WINDOWCOLOR = 14
CONST SUNATTR = 3
CONST SUNHAPPY = FALSE
CONST SUNSHOCK = TRUE
CONST RIGHTUP = 1
CONST LEFTUP = 2
CONST ARMSDOWN = 3

'Global Variables
DIM SHARED GorillaX(1 TO 2)  'Location of the two gorillas
DIM SHARED GorillaY(1 TO 2)
DIM SHARED LastBuilding

DIM SHARED pi#
DIM SHARED LBan&(x), RBan&(x), UBan&(x), DBan&(x) 'Graphical picture of banana
DIM SHARED GorD&(120)        'Graphical picture of Gorilla arms down
DIM SHARED GorL&(120)        'Gorilla left arm raised
DIM SHARED GorR&(120)        'Gorilla right arm raised

DIM SHARED gravity#
DIM SHARED Wind

'Screen Mode Variables
DIM SHARED ScrHeight
DIM SHARED ScrWidth
DIM SHARED Mode
DIM SHARED MaxCol

'Screen Color Variables
DIM SHARED ExplosionColor
DIM SHARED SunColor
DIM SHARED BackColor
DIM SHARED SunHit

DIM SHARED SunHt
DIM SHARED GHeight
DIM SHARED MachSpeed AS SINGLE

  DEF FnRan (x) = INT(RND(1) * x) + 1
  DEF SEG = 0                         ' Set NumLock to ON
  KeyFlags = PEEK(1047)
  IF (KeyFlags AND 32) = 0 THEN
    POKE 1047, KeyFlags OR 32
  END IF
  DEF SEG

  GOSUB InitVars
  Intro
  GetInputs Name1$, Name2$, NumGames
  GorillaIntro Name1$, Name2$
  PlayGame Name1$, Name2$, NumGames

  DEF SEG = 0                         ' Restore NumLock state
  POKE 1047, KeyFlags
  DEF SEG
END


CGABanana:
  'BananaLeft
  DATA 327686, -252645316, 60
  'BananaDown
  DATA 196618, -1057030081, 49344
  'BananaUp
  DATA 196618, -1056980800, 63
  'BananaRight
  DATA 327686,  1010580720, 240

EGABanana:
  'BananaLeft
  DATA 458758,202116096,471604224,943208448,943208448,943208448,471604224,202116096,0
  'BananaDown
  DATA 262153, -2134835200, -2134802239, -2130771968, -2130738945,8323072, 8323199, 4063232, 4063294
  'BananaUp
  DATA 262153, 4063232, 4063294, 8323072, 8323199, -2130771968, -2130738945, -2134835200,-2134802239
  'BananaRight
  DATA 458758, -1061109760, -522133504, 1886416896, 1886416896, 1886416896,-522133504,-1061109760,0

InitVars:
  pi# = 4 * ATN(1#)

  'This is a clever way to pick the best graphics mode available
  ON ERROR GOTO ScreenModeError
  Mode = 9
  SCREEN Mode
  ON ERROR GOTO PaletteError
  IF Mode = 9 THEN PALETTE 4, 0   'Check for 64K EGA
  ON ERROR GOTO 0

  MachSpeed = CalcDelay

  IF Mode = 9 THEN
    ScrWidth = 640
    ScrHeight = 350
    GHeight = 25
    RESTORE EGABanana
    REDIM LBan&(8), RBan&(8), UBan&(8), DBan&(8)

    FOR i = 0 TO 8
      READ LBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ DBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ UBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ RBan&(i)
    NEXT i

    SunHt = 39

  ELSE

    ScrWidth = 320
    ScrHeight = 200
    GHeight = 12
    RESTORE CGABanana
    REDIM LBan&(2), RBan&(2), UBan&(2), DBan&(2)
    REDIM GorL&(20), GorD&(20), GorR&(20)

    FOR i = 0 TO 2
      READ LBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ DBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ UBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ RBan&(i)
    NEXT i

    MachSpeed = MachSpeed * 1.3
    SunHt = 20
  END IF
RETURN

ScreenModeError:
  IF Mode = 1 THEN
    CLS
    LOCATE 10, 5
    PRINT "Sorry, you must have CGA, EGA color, or VGA graphics to play GORILLA.BAS"
    END
  ELSE
    Mode = 1
    RESUME
  END IF

PaletteError:
  Mode = 1            '64K EGA cards will run in CGA mode.
  RESUME NEXT

REM $STATIC
'CalcDelay:
'  Checks speed of the machine.
FUNCTION CalcDelay!

  s! = TIMER
  DO
    i! = i! + 1
  LOOP UNTIL TIMER - s! >= .5
  CalcDelay! = i!

END FUNCTION

' Center:
'   Centers and prints a text string on a given row
' Parameters:
'   Row - screen row number
'   Text$ - text to be printed
'
SUB Center (Row, Text$)
  Col = MaxCol \ 2
  LOCATE Row, Col - (LEN(Text$) / 2 + .5)
  PRINT Text$;
END SUB

' DoExplosion:
'   Produces explosion when a shot is fired
' Parameters:
'   X#, Y# - location of explosion
'
SUB DoExplosion (x#, y#)

  PLAY "MBO0L32EFGEFDC"
  Radius = ScrHeight / 50
  IF Mode = 9 THEN Inc# = .5 ELSE Inc# = .41
  FOR c# = 0 TO Radius STEP Inc#
    CIRCLE (x#, y#), c#, ExplosionColor
  NEXT c#
  FOR c# = Radius TO 0 STEP (-1 * Inc#)
    CIRCLE (x#, y#), c#, BACKATTR
    FOR i = 1 TO 100
    NEXT i
    Rest .005
  NEXT c#
END SUB

' DoShot:
'   Controls banana shots by accepting player input and plotting
'   shot angle
' Parameters:
'   PlayerNum - Player
'   x, y - Player's gorilla position
'
FUNCTION DoShot (PlayerNum, x, y)

  'Input shot
  IF PlayerNum = 1 THEN
    LocateCol = 1
  ELSE
    IF Mode = 9 THEN
      LocateCol = 66
    ELSE
      LocateCol = 26
    END IF
  END IF

  LOCATE 2, LocateCol
  PRINT "Angle:";
  Angle# = GetNum#(2, LocateCol + 7)

  LOCATE 3, LocateCol
  PRINT "Velocity:";
  Velocity = GetNum#(3, LocateCol + 10)

  IF PlayerNum = 2 THEN
    Angle# = 180 - Angle#
  END IF

  'Erase input
  FOR i = 1 TO 4
    LOCATE i, 1
    PRINT SPACE$(30 \ (80 \ MaxCol));
    LOCATE i, (50 \ (80 \ MaxCol))
    PRINT SPACE$(30 \ (80 \ MaxCol));
  NEXT

  SunHit = FALSE
  PlayerHit = PlotShot(x, y, Angle#, Velocity, PlayerNum)
  IF PlayerHit = 0 THEN
    DoShot = FALSE
  ELSE
    DoShot = TRUE
    IF PlayerHit = PlayerNum THEN PlayerNum = 3 - PlayerNum
    VictoryDance PlayerNum
  END IF

END FUNCTION

' DoSun:
'   Draws the sun at the top of the screen.
' Parameters:
'   Mouth - If TRUE draws "O" mouth else draws a smile mouth.
'
SUB DoSun (Mouth)

  'set position of sun
  x = ScrWidth \ 2: y = Scl(25)

  'clear old sun
  LINE (x - Scl(22), y - Scl(18))-(x + Scl(22), y + Scl(18)), BACKATTR, BF

  'draw new sun:
  'body
  CIRCLE (x, y), Scl(12), SUNATTR
  PAINT (x, y), SUNATTR

  'rays
  LINE (x - Scl(20), y)-(x + Scl(20), y), SUNATTR
  LINE (x, y - Scl(15))-(x, y + Scl(15)), SUNATTR

  LINE (x - Scl(15), y - Scl(10))-(x + Scl(15), y + Scl(10)), SUNATTR
  LINE (x - Scl(15), y + Scl(10))-(x + Scl(15), y - Scl(10)), SUNATTR

  LINE (x - Scl(8), y - Scl(13))-(x + Scl(8), y + Scl(13)), SUNATTR
  LINE (x - Scl(8), y + Scl(13))-(x + Scl(8), y - Scl(13)), SUNATTR

  LINE (x - Scl(18), y - Scl(5))-(x + Scl(18), y + Scl(5)), SUNATTR
  LINE (x - Scl(18), y + Scl(5))-(x + Scl(18), y - Scl(5)), SUNATTR

  'mouth
  IF Mouth THEN  'draw "o" mouth
    CIRCLE (x, y + Scl(5)), Scl(2.9), 0
    PAINT (x, y + Scl(5)), 0, 0
  ELSE           'draw smile
    CIRCLE (x, y), Scl(8), 0, (210 * pi# / 180), (330 * pi# / 180)
  END IF

  'eyes
  CIRCLE (x - 3, y - 2), 1, 0
  CIRCLE (x + 3, y - 2), 1, 0
  PSET (x - 3, y - 2), 0
  PSET (x + 3, y - 2), 0

END SUB

'DrawBan:
'  Draws the banana
'Parameters:
'  xc# - Horizontal Coordinate
'  yc# - Vertical Coordinate
'  r - rotation position (0-3). (  \_/  ) /-\
'  bc - if TRUE then DrawBan draws the banana ELSE it erases the banana
SUB DrawBan (xc#, yc#, r, bc)

SELECT CASE r
  CASE 0
    IF bc THEN PUT (xc#, yc#), LBan&, PSET ELSE PUT (xc#, yc#), LBan&, XOR
  CASE 1
    IF bc THEN PUT (xc#, yc#), UBan&, PSET ELSE PUT (xc#, yc#), UBan&, XOR
  CASE 2
    IF bc THEN PUT (xc#, yc#), DBan&, PSET ELSE PUT (xc#, yc#), DBan&, XOR
  CASE 3
    IF bc THEN PUT (xc#, yc#), RBan&, PSET ELSE PUT (xc#, yc#), RBan&, XOR
END SELECT

END SUB

'DrawGorilla:
'  Draws the Gorilla in either CGA or EGA mode
'  and saves the graphics data in an array.
'Parameters:
'  x - x coordinate of gorilla
'  y - y coordinate of the gorilla
'  arms - either Left up, Right up, or both down
SUB DrawGorilla (x, y, arms)
  DIM i AS SINGLE   ' Local index must be single precision

  'draw head
  LINE (x - Scl(4), y)-(x + Scl(2.9), y + Scl(6)), OBJECTCOLOR, BF
  LINE (x - Scl(5), y + Scl(2))-(x + Scl(4), y + Scl(4)), OBJECTCOLOR, BF

  'draw eyes/brow
  LINE (x - Scl(3), y + Scl(2))-(x + Scl(2), y + Scl(2)), 0

  'draw nose if ega
  IF Mode = 9 THEN
    FOR i = -2 TO -1
      PSET (x + i, y + 4), 0
      PSET (x + i + 3, y + 4), 0
    NEXT i
  END IF

  'neck
  LINE (x - Scl(3), y + Scl(7))-(x + Scl(2), y + Scl(7)), OBJECTCOLOR

  'body
  LINE (x - Scl(8), y + Scl(8))-(x + Scl(6.9), y + Scl(14)), OBJECTCOLOR, BF
  LINE (x - Scl(6), y + Scl(15))-(x + Scl(4.9), y + Scl(20)), OBJECTCOLOR, BF

  'legs
  FOR i = 0 TO 4
    CIRCLE (x + Scl(i), y + Scl(25)), Scl(10), OBJECTCOLOR, 3 * pi# / 4, 9 * pi# / 8
    CIRCLE (x + Scl(-6) + Scl(i - .1), y + Scl(25)), Scl(10), OBJECTCOLOR, 15 * pi# / 8, pi# / 4
  NEXT

  'chest
  CIRCLE (x - Scl(4.9), y + Scl(10)), Scl(4.9), 0, 3 * pi# / 2, 0
  CIRCLE (x + Scl(4.9), y + Scl(10)), Scl(4.9), 0, pi#, 3 * pi# / 2

  FOR i = -5 TO -1
    SELECT CASE arms
      CASE 1
        'Right arm up
        CIRCLE (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(4)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorR&
      CASE 2
        'Left arm up
        CIRCLE (x + Scl(i - .1), y + Scl(4)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorL&
      CASE 3
        'Both arms down
        CIRCLE (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorD&
    END SELECT
  NEXT i
END SUB

'ExplodeGorilla:
'  Causes gorilla explosion when a direct hit occurs
'Parameters:
'  X#, Y# - shot location
FUNCTION ExplodeGorilla (x#, y#)
  YAdj = Scl(12)
  XAdj = Scl(5)
  SclX# = ScrWidth / 320
  SclY# = ScrHeight / 200
  IF x# < ScrWidth / 2 THEN PlayerHit = 1 ELSE PlayerHit = 2
  PLAY "MBO0L16EFGEFDC"

  FOR i = 1 TO 8 * SclX#
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), i, ExplosionColor, , , -1.57
    LINE (GorillaX(PlayerHit) + 7 * SclX#, GorillaY(PlayerHit) + 9 * SclY# - i)-(GorillaX(PlayerHit), GorillaY(PlayerHit) + 9 * SclY# - i), ExplosionColor
  NEXT i

  FOR i = 1 TO 16 * SclX#
    IF i < (8 * SclX#) THEN CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), (8 * SclX# + 1) - i, BACKATTR, , , -1.57
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, i MOD 2 + 1, , , -1.57
  NEXT i

  FOR i = 24 * SclX# TO 1 STEP -1
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, BACKATTR, , , -1.57
    FOR Count = 1 TO 200
    NEXT
  NEXT i

  ExplodeGorilla = PlayerHit
END FUNCTION

'GetInputs:
'  Gets user inputs at beginning of game
'Parameters:
'  Player1$, Player2$ - player names
'  NumGames - number of games to play
SUB GetInputs (Player1$, Player2$, NumGames)
  COLOR 7, 0
  CLS

  LOCATE 8, 15
  LINE INPUT "Name of Player 1 (Default = 'Player 1'): "; Player1$
  IF Player1$ = "" THEN
    Player1$ = "Player 1"
  ELSE
    Player1$ = LEFT$(Player1$, 10)
  END IF

  LOCATE 10, 15
  LINE INPUT "Name of Player 2 (Default = 'Player 2'): "; Player2$
  IF Player2$ = "" THEN
    Player2$ = "Player 2"
  ELSE
    Player2$ = LEFT$(Player2$, 10)
  END IF

  DO
    LOCATE 12, 56: PRINT SPACE$(25);
    LOCATE 12, 13
    INPUT "Play to how many total points (Default = 3)"; game$
    NumGames = VAL(LEFT$(game$, 2))
  LOOP UNTIL NumGames > 0 AND LEN(game$) < 3 OR LEN(game$) = 0
  IF NumGames = 0 THEN NumGames = 3

  DO
    LOCATE 14, 53: PRINT SPACE$(28);
    LOCATE 14, 17
    INPUT "Gravity in Meters/Sec (Earth = 9.8)"; grav$
    gravity# = VAL(grav$)
  LOOP UNTIL gravity# > 0 OR LEN(grav$) = 0
  IF gravity# = 0 THEN gravity# = 9.8
END SUB

'GetNum:
'  Gets valid numeric input from user
'Parameters:
'  Row, Col - location to echo input
FUNCTION GetNum# (Row, Col)
  Result$ = ""
  Done = FALSE
  WHILE INKEY$ <> "": WEND   'Clear keyboard buffer

  DO WHILE NOT Done

    LOCATE Row, Col
    PRINT Result$; CHR$(95); "    ";

    Kbd$ = INKEY$
    SELECT CASE Kbd$
      CASE "0" TO "9"
        Result$ = Result$ + Kbd$
      CASE "."
        IF INSTR(Result$, ".") = 0 THEN
          Result$ = Result$ + Kbd$
        END IF
      CASE CHR$(13)
        IF VAL(Result$) > 360 THEN
          Result$ = ""
        ELSE
          Done = TRUE
        END IF
      CASE CHR$(8)
        IF LEN(Result$) > 0 THEN
          Result$ = LEFT$(Result$, LEN(Result$) - 1)
        END IF
      CASE ELSE
        IF LEN(Kbd$) > 0 THEN
          BEEP
        END IF
      END SELECT
  LOOP

  LOCATE Row, Col
  PRINT Result$; " ";

  GetNum# = VAL(Result$)
END FUNCTION

'GorillaIntro:
'  Displays gorillas on screen for the first time
'  allows the graphical data to be put into an array
'Parameters:
'  Player1$, Player2$ - The names of the players
'
SUB GorillaIntro (Player1$, Player2$)
  LOCATE 16, 34: PRINT "--------------"
  LOCATE 18, 34: PRINT "V = View Intro"
  LOCATE 19, 34: PRINT "P = Play Game"
  LOCATE 21, 35: PRINT "Your Choice?"

  DO WHILE Char$ = ""
    Char$ = INKEY$
  LOOP

  IF Mode = 1 THEN
    x = 125
    y = 100
  ELSE
    x = 278
    y = 175
  END IF

  SCREEN Mode
  SetScreen

  IF Mode = 1 THEN Center 5, "Please wait while gorillas are drawn."

  VIEW PRINT 9 TO 24

  IF Mode = 9 THEN PALETTE OBJECTCOLOR, BackColor

  DrawGorilla x, y, ARMSDOWN
  CLS 2
  DrawGorilla x, y, LEFTUP
  CLS 2
  DrawGorilla x, y, RIGHTUP
  CLS 2

  VIEW PRINT 1 TO 25
  IF Mode = 9 THEN PALETTE OBJECTCOLOR, 46

  IF UCASE$(Char$) = "V" THEN
    Center 2, "Q B A S I C   G O R I L L A S"
    Center 5, "             STARRING:               "
    P$ = Player1$ + " AND " + Player2$
    Center 7, P$

    PUT (x - 13, y), GorD&, PSET
    PUT (x + 47, y), GorD&, PSET
    Rest 1

    PUT (x - 13, y), GorL&, PSET
    PUT (x + 47, y), GorR&, PSET
    PLAY "t120o1l16b9n0baan0bn0bn0baaan0b9n0baan0b"
    Rest .3

    PUT (x - 13, y), GorR&, PSET
    PUT (x + 47, y), GorL&, PSET
    PLAY "o2l16e-9n0e-d-d-n0e-n0e-n0e-d-d-d-n0e-9n0e-d-d-n0e-"
    Rest .3

    PUT (x - 13, y), GorL&, PSET
    PUT (x + 47, y), GorR&, PSET
    PLAY "o2l16g-9n0g-een0g-n0g-n0g-eeen0g-9n0g-een0g-"
    Rest .3

    PUT (x - 13, y), GorR&, PSET
    PUT (x + 47, y), GorL&, PSET
    PLAY "o2l16b9n0baan0g-n0g-n0g-eeen0o1b9n0baan0b"
    Rest .3

    FOR i = 1 TO 4
      PUT (x - 13, y), GorL&, PSET
      PUT (x + 47, y), GorR&, PSET
      PLAY "T160O0L32EFGEFDC"
      Rest .1
      PUT (x - 13, y), GorR&, PSET
      PUT (x + 47, y), GorL&, PSET
      PLAY "T160O0L32EFGEFDC"
      Rest .1
    NEXT
  END IF
END SUB

'Intro:
'  Displays game introduction
SUB Intro

  SCREEN 0
  WIDTH 80, 25
  MaxCol = 80
  COLOR 15, 0
  CLS

  Center 4, "Q B a s i c    G O R I L L A S"
  COLOR 7
  Center 6, "Copyright (C) IBM Corporation 1991"
  Center 8, "Your mission is to hit your opponent with the exploding"
  Center 9, "banana by varying the angle and power of your throw, taking"
  Center 10, "into account wind speed, gravity, and the city skyline."
  Center 11, "The wind speed is shown by a directional arrow at the bottom"
  Center 12, "of the playing field, its length relative to its strength."
  Center 24, "Press any key to continue"

  PLAY "MBT160O1L8CDEDCDL4ECC"
  SparklePause
  IF Mode = 1 THEN MaxCol = 40
END SUB

'MakeCityScape:
'  Creates random skyline for game
'Parameters:
'  BCoor() - a user-defined type array which stores the coordinates of
'  the upper left corner of each building.
SUB MakeCityScape (BCoor() AS XYPoint)

  x = 2

  'Set the sloping trend of the city scape. NewHt is new building height
  Slope = FnRan(6)
  SELECT CASE Slope
    CASE 1: NewHt = 15                 'Upward slope
    CASE 2: NewHt = 130                'Downward slope
    CASE 3 TO 5: NewHt = 15            '"V" slope - most common
    CASE 6: NewHt = 130                'Inverted "V" slope
  END SELECT

  IF Mode = 9 THEN
    BottomLine = 335                   'Bottom of building
    HtInc = 10                         'Increase value for new height
    DefBWidth = 37                     'Default building height
    RandomHeight = 120                 'Random height difference
    WWidth = 3                         'Window width
    WHeight = 6                        'Window height
    WDifV = 15                         'Counter for window spacing - vertical
    WDifh = 10                         'Counter for window spacing - horizontal
  ELSE
    BottomLine = 190
    HtInc = 6
    NewHt = NewHt * 20 \ 35            'Adjust for CGA
    DefBWidth = 18
    RandomHeight = 54
    WWidth = 1
    WHeight = 2
    WDifV = 5
    WDifh = 4
  END IF

  CurBuilding = 1
  DO

    SELECT CASE Slope
      CASE 1
        NewHt = NewHt + HtInc
      CASE 2
        NewHt = NewHt - HtInc
      CASE 3 TO 5
        IF x > ScrWidth \ 2 THEN
          NewHt = NewHt - 2 * HtInc
        ELSE
          NewHt = NewHt + 2 * HtInc
        END IF
      CASE 4
        IF x > ScrWidth \ 2 THEN
          NewHt = NewHt + 2 * HtInc
        ELSE
          NewHt = NewHt - 2 * HtInc
        END IF
    END SELECT

    'Set width of building and check to see if it would go off the screen
    BWidth = FnRan(DefBWidth) + DefBWidth
    IF x + BWidth > ScrWidth THEN BWidth = ScrWidth - x - 2

    'Set height of building and check to see if it goes below screen
    BHeight = FnRan(RandomHeight) + NewHt
    IF BHeight < HtInc THEN BHeight = HtInc

    'Check to see if Building is too high
    IF BottomLine - BHeight <= MaxHeight + GHeight THEN BHeight = MaxHeight + GHeight - 5

    'Set the coordinates of the building into the array
    BCoor(CurBuilding).XCoor = x
    BCoor(CurBuilding).YCoor = BottomLine - BHeight

    IF Mode = 9 THEN BuildingColor = FnRan(3) + 4 ELSE BuildingColor = 2

    'Draw the building, outline first, then filled
    LINE (x - 1, BottomLine + 1)-(x + BWidth + 1, BottomLine - BHeight - 1), BACKGROUND, B
    LINE (x, BottomLine)-(x + BWidth, BottomLine - BHeight), BuildingColor, BF

    'Draw the windows
    c = x + 3
    DO
      FOR i = BHeight - 3 TO 7 STEP -WDifV
        IF Mode <> 9 THEN
          WinColr = (FnRan(2) - 2) * -3
        ELSEIF FnRan(4) = 1 THEN
          WinColr = 8
        ELSE
          WinColr = WINDOWCOLOR
        END IF
        LINE (c, BottomLine - i)-(c + WWidth, BottomLine - i + WHeight), WinColr, BF
      NEXT
      c = c + WDifh
    LOOP UNTIL c >= x + BWidth - 3

    x = x + BWidth + 2

    CurBuilding = CurBuilding + 1

  LOOP UNTIL x > ScrWidth - HtInc

  LastBuilding = CurBuilding - 1

  'Set Wind speed
  Wind = FnRan(10) - 5
  IF FnRan(3) = 1 THEN
    IF Wind > 0 THEN
      Wind = Wind + FnRan(10)
    ELSE
      Wind = Wind - FnRan(10)
    END IF
  END IF

  'Draw Wind speed arrow
  IF Wind <> 0 THEN
    WindLine = Wind * 3 * (ScrWidth \ 320)
    LINE (ScrWidth \ 2, ScrHeight - 5)-(ScrWidth \ 2 + WindLine, ScrHeight - 5), ExplosionColor
    IF Wind > 0 THEN ArrowDir = -2 ELSE ArrowDir = 2
    LINE (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 - 2), ExplosionColor
    LINE (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 + 2), ExplosionColor
  END IF
END SUB

'PlaceGorillas:
'  PUTs the Gorillas on top of the buildings.  Must have drawn
'  Gorillas first.
'Parameters:
'  BCoor() - user-defined TYPE array which stores upper left coordinates
'  of each building.
SUB PlaceGorillas (BCoor() AS XYPoint)

  IF Mode = 9 THEN
    XAdj = 14
    YAdj = 30
  ELSE
    XAdj = 7
    YAdj = 16
  END IF
  SclX# = ScrWidth / 320
  SclY# = ScrHeight / 200

  'Place gorillas on second or third building from edge
  FOR i = 1 TO 2
    IF i = 1 THEN BNum = FnRan(2) + 1 ELSE BNum = LastBuilding - FnRan(2)

    BWidth = BCoor(BNum + 1).XCoor - BCoor(BNum).XCoor
    GorillaX(i) = BCoor(BNum).XCoor + BWidth / 2 - XAdj
    GorillaY(i) = BCoor(BNum).YCoor - YAdj
    PUT (GorillaX(i), GorillaY(i)), GorD&, PSET
  NEXT i

END SUB

'PlayGame:
'  Main game play routine
'Parameters:
'  Player1$, Player2$ - player names
'  NumGames - number of games to play
SUB PlayGame (Player1$, Player2$, NumGames)
  DIM BCoor(0 TO 30) AS XYPoint
  DIM TotalWins(1 TO 2)

  J = 1

  FOR i = 1 TO NumGames

    CLS
    RANDOMIZE (TIMER)
    CALL MakeCityScape(BCoor())
    CALL PlaceGorillas(BCoor())
    DoSun SUNHAPPY
    Hit = FALSE
    DO WHILE Hit = FALSE
      J = 1 - J
      LOCATE 1, 1
      PRINT Player1$
      LOCATE 1, (MaxCol - 1 - LEN(Player2$))
      PRINT Player2$
      Center 23, LTRIM$(STR$(TotalWins(1))) + ">Score<" + LTRIM$(STR$(TotalWins(2)))
      Tosser = J + 1: Tossee = 3 - J

      'Plot the shot.  Hit is true if Gorilla gets hit.
      Hit = DoShot(Tosser, GorillaX(Tosser), GorillaY(Tosser))

      'Reset the sun, if it got hit
      IF SunHit THEN DoSun SUNHAPPY

      IF Hit = TRUE THEN CALL UpdateScores(TotalWins(), Tosser, Hit)
    LOOP
    SLEEP 1
  NEXT i

  SCREEN 0
  WIDTH 80, 25
  COLOR 7, 0
  MaxCol = 80
  CLS

  Center 8, "GAME OVER!"
  Center 10, "Score:"
  LOCATE 11, 30: PRINT Player1$; TAB(50); TotalWins(1)
  LOCATE 12, 30: PRINT Player2$; TAB(50); TotalWins(2)
  Center 24, "Press any key to continue"
  SparklePause
  COLOR 7, 0
  CLS
END SUB

'PlayGame:
'  Plots banana shot across the screen
'Parameters:
'  StartX, StartY - starting shot location
'  Angle - shot angle
'  Velocity - shot velocity
'  PlayerNum - the banana thrower
FUNCTION PlotShot (StartX, StartY, Angle#, Velocity, PlayerNum)

  Angle# = Angle# / 180 * pi#  'Convert degree angle to radians
  Radius = Mode MOD 7

  InitXVel# = COS(Angle#) * Velocity
  InitYVel# = SIN(Angle#) * Velocity

  oldx# = StartX
  oldy# = StartY

  'draw gorilla toss
  IF PlayerNum = 1 THEN
    PUT (StartX, StartY), GorL&, PSET
  ELSE
    PUT (StartX, StartY), GorR&, PSET
  END IF

  'throw sound
  PLAY "MBo0L32A-L64CL16BL64A+"
  Rest .1

  'redraw gorilla
  PUT (StartX, StartY), GorD&, PSET

  adjust = Scl(4)                   'For scaling CGA

  xedge = Scl(9) * (2 - PlayerNum)  'Find leading edge of banana for check

  Impact = FALSE
  ShotInSun = FALSE
  OnScreen = TRUE
  PlayerHit = 0
  NeedErase = FALSE

  StartXPos = StartX
  StartYPos = StartY - adjust - 3

  IF PlayerNum = 2 THEN
    StartXPos = StartXPos + Scl(25)
    direction = Scl(4)
  ELSE
    direction = Scl(-4)
  END IF

  IF Velocity < 2 THEN              'Shot too slow - hit self
    x# = StartX
    y# = StartY
    pointval = OBJECTCOLOR
  END IF

  DO WHILE (NOT Impact) AND OnScreen

  Rest .02

  'Erase old banana, if necessary
  IF NeedErase THEN
    NeedErase = FALSE
    CALL DrawBan(oldx#, oldy#, oldrot, FALSE)
  END IF

  x# = StartXPos + (InitXVel# * t#) + (.5 * (Wind / 5) * t# ^ 2)
  y# = StartYPos + ((-1 * (InitYVel# * t#)) + (.5 * gravity# * t# ^ 2)) * (ScrHeight / 350)

  IF (x# >= ScrWidth - Scl(10)) OR (x# <= 3) OR (y# >= ScrHeight - 3) THEN
    OnScreen = FALSE
  END IF


  IF OnScreen AND y# > 0 THEN

    'check it
    LookY = 0
    LookX = Scl(8 * (2 - PlayerNum))
    DO
      pointval = POINT(x# + LookX, y# + LookY)
      IF pointval = 0 THEN
        Impact = FALSE
        IF ShotInSun = TRUE THEN
          IF ABS(ScrWidth \ 2 - x#) > Scl(20) OR y# > SunHt THEN ShotInSun = FALSE
        END IF
      ELSEIF pointval = SUNATTR AND y# < SunHt THEN
        IF NOT SunHit THEN DoSun SUNSHOCK
        SunHit = TRUE
        ShotInSun = TRUE
      ELSE
        Impact = TRUE
      END IF
      LookX = LookX + direction
      LookY = LookY + Scl(6)
    LOOP UNTIL Impact OR LookX <> Scl(4)

    IF NOT ShotInSun AND NOT Impact THEN
      'plot it
      rot = (t# * 10) MOD 4
      CALL DrawBan(x#, y#, rot, TRUE)
      NeedErase = TRUE
    END IF

    oldx# = x#
    oldy# = y#
    oldrot = rot

  END IF


  t# = t# + .1

  LOOP

  IF pointval <> OBJECTCOLOR AND Impact THEN
    CALL DoExplosion(x# + adjust, y# + adjust)
  ELSEIF pointval = OBJECTCOLOR THEN
    PlayerHit = ExplodeGorilla(x#, y#)
  END IF

  PlotShot = PlayerHit

END FUNCTION

'Rest:
'  pauses the program
SUB Rest (t#)
  s# = TIMER
  t2# = MachSpeed * t# / SPEEDCONST
  DO
  LOOP UNTIL TIMER - s# > t2#
END SUB

'Scl:
'  Pass the number in to scaling for cga.  If the number is a decimal, then we
'  want to scale down for cga or scale up for ega.  This allows a full range
'  of numbers to be generated for scaling.
'  (i.e. for 3 to get scaled to 1, pass in 2.9)
FUNCTION Scl (n!)

  IF n! <> INT(n!) THEN
      IF Mode = 1 THEN n! = n! - 1
  END IF
  IF Mode = 1 THEN
      Scl = CINT(n! / 2 + .1)
  ELSE
      Scl = CINT(n!)
  END IF

END FUNCTION

'SetScreen:
'  Sets the appropriate color statements
SUB SetScreen

  IF Mode = 9 THEN
    ExplosionColor = 2
    BackColor = 1
    PALETTE 0, 1
    PALETTE 1, 46
    PALETTE 2, 44
    PALETTE 3, 54
    PALETTE 5, 7
    PALETTE 6, 4
    PALETTE 7, 3
    PALETTE 9, 63       'Display Color
  ELSE
    ExplosionColor = 2
    BackColor = 0
    COLOR BackColor, 2

  END IF

END SUB

'SparklePause:
'  Creates flashing border for intro and game over screens
SUB SparklePause

  COLOR 4, 0
  A$ = "*    *    *    *    *    *    *    *    *    *    *    *    *    *    *    *    *    "
  WHILE INKEY$ <> "": WEND 'Clear keyboard buffer

  WHILE INKEY$ = ""
    FOR A = 1 TO 5
      LOCATE 1, 1                             'print horizontal sparkles
      PRINT MID$(A$, A, 80);
      LOCATE 22, 1
      PRINT MID$(A$, 6 - A, 80);

      FOR b = 2 TO 21                         'Print Vertical sparkles
        c = (A + b) MOD 5
        IF c = 1 THEN
          LOCATE b, 80
          PRINT "*";
          LOCATE 23 - b, 1
          PRINT "*";
        ELSE
          LOCATE b, 80
          PRINT " ";
          LOCATE 23 - b, 1
          PRINT " ";
        END IF
      NEXT b
    NEXT A
  WEND
END SUB

'UpdateScores:
'  Updates players' scores
'Parameters:
'  Record - players' scores
'  PlayerNum - player
'  Results - results of player's shot
SUB UpdateScores (Record(), PlayerNum, Results)
  IF Results = HITSELF THEN
    Record(ABS(PlayerNum - 3)) = Record(ABS(PlayerNum - 3)) + 1
  ELSE
    Record(PlayerNum) = Record(PlayerNum) + 1
  END IF
END SUB

'VictoryDance:
'  gorilla dances after he has eliminated his opponent
'Parameters:
'  Player - which gorilla is dancing
SUB VictoryDance (Player)

  FOR i# = 1 TO 4
    PUT (GorillaX(Player), GorillaY(Player)), GorL&, PSET
    PLAY "MFO0L32EFGEFDC"
    Rest .2
    PUT (GorillaX(Player), GorillaY(Player)), GorR&, PSET
    PLAY "MFO0L32EFGEFDC"
    Rest .2
  NEXT
END SUB

Attachments


GORILAS.jpg (205.15 KiB)


GORILA-V2.jpg (241.89 KiB)


GORILA-V1.jpg (221.43 KiB)

GORILA.rar (144.71 KiB)
]]>
I want to apologize because I couldn't incorporate your code into my project.

En realidad el rebote fue fabuloso ver cómo funciona, pero en mi caso, creo que es necesario dirigir sólo un rebote hacia arriba, pero no pude dirigirlo hacia un punto específico del screen, como por ej 0,350 o 0,500 partiendo desde un punto específico.
Luego la caída también debe ser dirigida de acuerdo a la Distancia, es decir necesito manejar Ángulo y Distancia, tanto de subida como de bajada.
Quizás no logré adaptar tu código, debido a que ya he explicado varias veces no soy un profesional de la programación, sin embargo fui autodidacta y me gusta y me entusiasma mucho este mundo, es más te cuento que el programa anterior de la culebrita, no logré entender cuando colisionaba con la cola, sin embargo seguí buscando la forma de hacerlo y use una dbf para llevar el control, y lo hice :)

El juego que esta ocasión trato de actualizar (ah, por cierto muy chévere el Arkanoid, yo también lo jugué), es el de los Gorilas, hecho bajo Qbasic en los 90, adjuntaré el código original por si lo quieren revisar.

Estuve ausente unos días, porque me he estado rompiendo la cabeza y bueno, aún tengo unas dificultades como la dirección del ataque en sentido derecha-izquierda, sería interesante que al sentir la bomba disparada y al dar al objetivo, sienta que ese lugar está ocupado por el objetivo y estallar.

Deben haber hasta 6 juegos, donde los gorilas aparecen encima de los edificios del 1 al 6 (el gorila del lado izquierdo) y del 8 al 13 (el gorila del lado derecho) ... voy por el # 1 :oops: porque hay que pulir bien las situaciones del primer juego, luego los demás se añaden más fácil supongo.

Creo que será un jueguito muy simpático para todos, pero hay que meterle mano y ayudarme, porque sino, no sé cuándo terminaré :cry:

Estimado Edward, perdón porque tuve que seguir usando la imagen tapada, usando ahora release en vez de hide, creo funciona mejor.

Saludos a todos
Louis

Este es el código original ...

Code: Select all

'                         Q B a s i c   G o r i l l a s
'
'                      Copyright (C) IBM Corporation 1991
'
' Your mission is to hit your opponent with the exploding banana
' by varying the angle and power of your throw, taking into account
' wind speed, gravity, and the city skyline.
'
' Speed of this game is determined by the constant SPEEDCONST.  If the
' program is too slow or too fast adjust the "CONST SPEEDCONST = 500" line
' below.  The larger the number the faster the game will go.
'
' To run this game, press Shift+F5.
'
' To exit QBasic, press Alt, F, X.
'
' To get help on a BASIC keyword, move the cursor to the keyword and press
' F1 or click the right mouse button.
'

'Set default data type to integer for faster game play
DEFINT A-Z

'Sub Declarations
DECLARE SUB DoSun (Mouth)
DECLARE SUB SetScreen ()
DECLARE SUB EndGame ()
DECLARE SUB Center (Row, Text$)
DECLARE SUB Intro ()
DECLARE SUB SparklePause ()
DECLARE SUB GetInputs (Player1$, Player2$, NumGames)
DECLARE SUB PlayGame (Player1$, Player2$, NumGames)
DECLARE SUB DoExplosion (x#, y#)
DECLARE SUB MakeCityScape (BCoor() AS ANY)
DECLARE SUB PlaceGorillas (BCoor() AS ANY)
DECLARE SUB UpdateScores (Record(), PlayerNum, Results)
DECLARE SUB DrawGorilla (x, y, arms)
DECLARE SUB GorillaIntro (Player1$, Player2$)
DECLARE SUB Rest (t#)
DECLARE SUB VictoryDance (Player)
DECLARE SUB ClearGorillas ()
DECLARE SUB DrawBan (xc#, yc#, r, bc)
DECLARE FUNCTION Scl (n!)
DECLARE FUNCTION GetNum# (Row, Col)
DECLARE FUNCTION DoShot (PlayerNum, x, y)
DECLARE FUNCTION ExplodeGorilla (x#, y#)
DECLARE FUNCTION Getn# (Row, Col)
DECLARE FUNCTION PlotShot (StartX, StartY, Angle#, Velocity, PlayerNum)
DECLARE FUNCTION CalcDelay! ()

'Make all arrays Dynamic
'$DYNAMIC

'User-Defined TYPEs
TYPE XYPoint
  XCoor AS INTEGER
  YCoor AS INTEGER
END TYPE

'Constants
CONST SPEEDCONST = 2500
CONST TRUE = -1
CONST FALSE = NOT TRUE
CONST HITSELF = 1
CONST BACKATTR = 0
CONST OBJECTCOLOR = 1
CONST WINDOWCOLOR = 14
CONST SUNATTR = 3
CONST SUNHAPPY = FALSE
CONST SUNSHOCK = TRUE
CONST RIGHTUP = 1
CONST LEFTUP = 2
CONST ARMSDOWN = 3

'Global Variables
DIM SHARED GorillaX(1 TO 2)  'Location of the two gorillas
DIM SHARED GorillaY(1 TO 2)
DIM SHARED LastBuilding

DIM SHARED pi#
DIM SHARED LBan&(x), RBan&(x), UBan&(x), DBan&(x) 'Graphical picture of banana
DIM SHARED GorD&(120)        'Graphical picture of Gorilla arms down
DIM SHARED GorL&(120)        'Gorilla left arm raised
DIM SHARED GorR&(120)        'Gorilla right arm raised

DIM SHARED gravity#
DIM SHARED Wind

'Screen Mode Variables
DIM SHARED ScrHeight
DIM SHARED ScrWidth
DIM SHARED Mode
DIM SHARED MaxCol

'Screen Color Variables
DIM SHARED ExplosionColor
DIM SHARED SunColor
DIM SHARED BackColor
DIM SHARED SunHit

DIM SHARED SunHt
DIM SHARED GHeight
DIM SHARED MachSpeed AS SINGLE

  DEF FnRan (x) = INT(RND(1) * x) + 1
  DEF SEG = 0                         ' Set NumLock to ON
  KeyFlags = PEEK(1047)
  IF (KeyFlags AND 32) = 0 THEN
    POKE 1047, KeyFlags OR 32
  END IF
  DEF SEG

  GOSUB InitVars
  Intro
  GetInputs Name1$, Name2$, NumGames
  GorillaIntro Name1$, Name2$
  PlayGame Name1$, Name2$, NumGames

  DEF SEG = 0                         ' Restore NumLock state
  POKE 1047, KeyFlags
  DEF SEG
END


CGABanana:
  'BananaLeft
  DATA 327686, -252645316, 60
  'BananaDown
  DATA 196618, -1057030081, 49344
  'BananaUp
  DATA 196618, -1056980800, 63
  'BananaRight
  DATA 327686,  1010580720, 240

EGABanana:
  'BananaLeft
  DATA 458758,202116096,471604224,943208448,943208448,943208448,471604224,202116096,0
  'BananaDown
  DATA 262153, -2134835200, -2134802239, -2130771968, -2130738945,8323072, 8323199, 4063232, 4063294
  'BananaUp
  DATA 262153, 4063232, 4063294, 8323072, 8323199, -2130771968, -2130738945, -2134835200,-2134802239
  'BananaRight
  DATA 458758, -1061109760, -522133504, 1886416896, 1886416896, 1886416896,-522133504,-1061109760,0

InitVars:
  pi# = 4 * ATN(1#)

  'This is a clever way to pick the best graphics mode available
  ON ERROR GOTO ScreenModeError
  Mode = 9
  SCREEN Mode
  ON ERROR GOTO PaletteError
  IF Mode = 9 THEN PALETTE 4, 0   'Check for 64K EGA
  ON ERROR GOTO 0

  MachSpeed = CalcDelay

  IF Mode = 9 THEN
    ScrWidth = 640
    ScrHeight = 350
    GHeight = 25
    RESTORE EGABanana
    REDIM LBan&(8), RBan&(8), UBan&(8), DBan&(8)

    FOR i = 0 TO 8
      READ LBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ DBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ UBan&(i)
    NEXT i

    FOR i = 0 TO 8
      READ RBan&(i)
    NEXT i

    SunHt = 39

  ELSE

    ScrWidth = 320
    ScrHeight = 200
    GHeight = 12
    RESTORE CGABanana
    REDIM LBan&(2), RBan&(2), UBan&(2), DBan&(2)
    REDIM GorL&(20), GorD&(20), GorR&(20)

    FOR i = 0 TO 2
      READ LBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ DBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ UBan&(i)
    NEXT i
    FOR i = 0 TO 2
      READ RBan&(i)
    NEXT i

    MachSpeed = MachSpeed * 1.3
    SunHt = 20
  END IF
RETURN

ScreenModeError:
  IF Mode = 1 THEN
    CLS
    LOCATE 10, 5
    PRINT "Sorry, you must have CGA, EGA color, or VGA graphics to play GORILLA.BAS"
    END
  ELSE
    Mode = 1
    RESUME
  END IF

PaletteError:
  Mode = 1            '64K EGA cards will run in CGA mode.
  RESUME NEXT

REM $STATIC
'CalcDelay:
'  Checks speed of the machine.
FUNCTION CalcDelay!

  s! = TIMER
  DO
    i! = i! + 1
  LOOP UNTIL TIMER - s! >= .5
  CalcDelay! = i!

END FUNCTION

' Center:
'   Centers and prints a text string on a given row
' Parameters:
'   Row - screen row number
'   Text$ - text to be printed
'
SUB Center (Row, Text$)
  Col = MaxCol \ 2
  LOCATE Row, Col - (LEN(Text$) / 2 + .5)
  PRINT Text$;
END SUB

' DoExplosion:
'   Produces explosion when a shot is fired
' Parameters:
'   X#, Y# - location of explosion
'
SUB DoExplosion (x#, y#)

  PLAY "MBO0L32EFGEFDC"
  Radius = ScrHeight / 50
  IF Mode = 9 THEN Inc# = .5 ELSE Inc# = .41
  FOR c# = 0 TO Radius STEP Inc#
    CIRCLE (x#, y#), c#, ExplosionColor
  NEXT c#
  FOR c# = Radius TO 0 STEP (-1 * Inc#)
    CIRCLE (x#, y#), c#, BACKATTR
    FOR i = 1 TO 100
    NEXT i
    Rest .005
  NEXT c#
END SUB

' DoShot:
'   Controls banana shots by accepting player input and plotting
'   shot angle
' Parameters:
'   PlayerNum - Player
'   x, y - Player's gorilla position
'
FUNCTION DoShot (PlayerNum, x, y)

  'Input shot
  IF PlayerNum = 1 THEN
    LocateCol = 1
  ELSE
    IF Mode = 9 THEN
      LocateCol = 66
    ELSE
      LocateCol = 26
    END IF
  END IF

  LOCATE 2, LocateCol
  PRINT "Angle:";
  Angle# = GetNum#(2, LocateCol + 7)

  LOCATE 3, LocateCol
  PRINT "Velocity:";
  Velocity = GetNum#(3, LocateCol + 10)

  IF PlayerNum = 2 THEN
    Angle# = 180 - Angle#
  END IF

  'Erase input
  FOR i = 1 TO 4
    LOCATE i, 1
    PRINT SPACE$(30 \ (80 \ MaxCol));
    LOCATE i, (50 \ (80 \ MaxCol))
    PRINT SPACE$(30 \ (80 \ MaxCol));
  NEXT

  SunHit = FALSE
  PlayerHit = PlotShot(x, y, Angle#, Velocity, PlayerNum)
  IF PlayerHit = 0 THEN
    DoShot = FALSE
  ELSE
    DoShot = TRUE
    IF PlayerHit = PlayerNum THEN PlayerNum = 3 - PlayerNum
    VictoryDance PlayerNum
  END IF

END FUNCTION

' DoSun:
'   Draws the sun at the top of the screen.
' Parameters:
'   Mouth - If TRUE draws "O" mouth else draws a smile mouth.
'
SUB DoSun (Mouth)

  'set position of sun
  x = ScrWidth \ 2: y = Scl(25)

  'clear old sun
  LINE (x - Scl(22), y - Scl(18))-(x + Scl(22), y + Scl(18)), BACKATTR, BF

  'draw new sun:
  'body
  CIRCLE (x, y), Scl(12), SUNATTR
  PAINT (x, y), SUNATTR

  'rays
  LINE (x - Scl(20), y)-(x + Scl(20), y), SUNATTR
  LINE (x, y - Scl(15))-(x, y + Scl(15)), SUNATTR

  LINE (x - Scl(15), y - Scl(10))-(x + Scl(15), y + Scl(10)), SUNATTR
  LINE (x - Scl(15), y + Scl(10))-(x + Scl(15), y - Scl(10)), SUNATTR

  LINE (x - Scl(8), y - Scl(13))-(x + Scl(8), y + Scl(13)), SUNATTR
  LINE (x - Scl(8), y + Scl(13))-(x + Scl(8), y - Scl(13)), SUNATTR

  LINE (x - Scl(18), y - Scl(5))-(x + Scl(18), y + Scl(5)), SUNATTR
  LINE (x - Scl(18), y + Scl(5))-(x + Scl(18), y - Scl(5)), SUNATTR

  'mouth
  IF Mouth THEN  'draw "o" mouth
    CIRCLE (x, y + Scl(5)), Scl(2.9), 0
    PAINT (x, y + Scl(5)), 0, 0
  ELSE           'draw smile
    CIRCLE (x, y), Scl(8), 0, (210 * pi# / 180), (330 * pi# / 180)
  END IF

  'eyes
  CIRCLE (x - 3, y - 2), 1, 0
  CIRCLE (x + 3, y - 2), 1, 0
  PSET (x - 3, y - 2), 0
  PSET (x + 3, y - 2), 0

END SUB

'DrawBan:
'  Draws the banana
'Parameters:
'  xc# - Horizontal Coordinate
'  yc# - Vertical Coordinate
'  r - rotation position (0-3). (  \_/  ) /-\
'  bc - if TRUE then DrawBan draws the banana ELSE it erases the banana
SUB DrawBan (xc#, yc#, r, bc)

SELECT CASE r
  CASE 0
    IF bc THEN PUT (xc#, yc#), LBan&, PSET ELSE PUT (xc#, yc#), LBan&, XOR
  CASE 1
    IF bc THEN PUT (xc#, yc#), UBan&, PSET ELSE PUT (xc#, yc#), UBan&, XOR
  CASE 2
    IF bc THEN PUT (xc#, yc#), DBan&, PSET ELSE PUT (xc#, yc#), DBan&, XOR
  CASE 3
    IF bc THEN PUT (xc#, yc#), RBan&, PSET ELSE PUT (xc#, yc#), RBan&, XOR
END SELECT

END SUB

'DrawGorilla:
'  Draws the Gorilla in either CGA or EGA mode
'  and saves the graphics data in an array.
'Parameters:
'  x - x coordinate of gorilla
'  y - y coordinate of the gorilla
'  arms - either Left up, Right up, or both down
SUB DrawGorilla (x, y, arms)
  DIM i AS SINGLE   ' Local index must be single precision

  'draw head
  LINE (x - Scl(4), y)-(x + Scl(2.9), y + Scl(6)), OBJECTCOLOR, BF
  LINE (x - Scl(5), y + Scl(2))-(x + Scl(4), y + Scl(4)), OBJECTCOLOR, BF

  'draw eyes/brow
  LINE (x - Scl(3), y + Scl(2))-(x + Scl(2), y + Scl(2)), 0

  'draw nose if ega
  IF Mode = 9 THEN
    FOR i = -2 TO -1
      PSET (x + i, y + 4), 0
      PSET (x + i + 3, y + 4), 0
    NEXT i
  END IF

  'neck
  LINE (x - Scl(3), y + Scl(7))-(x + Scl(2), y + Scl(7)), OBJECTCOLOR

  'body
  LINE (x - Scl(8), y + Scl(8))-(x + Scl(6.9), y + Scl(14)), OBJECTCOLOR, BF
  LINE (x - Scl(6), y + Scl(15))-(x + Scl(4.9), y + Scl(20)), OBJECTCOLOR, BF

  'legs
  FOR i = 0 TO 4
    CIRCLE (x + Scl(i), y + Scl(25)), Scl(10), OBJECTCOLOR, 3 * pi# / 4, 9 * pi# / 8
    CIRCLE (x + Scl(-6) + Scl(i - .1), y + Scl(25)), Scl(10), OBJECTCOLOR, 15 * pi# / 8, pi# / 4
  NEXT

  'chest
  CIRCLE (x - Scl(4.9), y + Scl(10)), Scl(4.9), 0, 3 * pi# / 2, 0
  CIRCLE (x + Scl(4.9), y + Scl(10)), Scl(4.9), 0, pi#, 3 * pi# / 2

  FOR i = -5 TO -1
    SELECT CASE arms
      CASE 1
        'Right arm up
        CIRCLE (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(4)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorR&
      CASE 2
        'Left arm up
        CIRCLE (x + Scl(i - .1), y + Scl(4)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorL&
      CASE 3
        'Both arms down
        CIRCLE (x + Scl(i - .1), y + Scl(14)), Scl(9), OBJECTCOLOR, 3 * pi# / 4, 5 * pi# / 4
        CIRCLE (x + Scl(4.9) + Scl(i), y + Scl(14)), Scl(9), OBJECTCOLOR, 7 * pi# / 4, pi# / 4
        GET (x - Scl(15), y - Scl(1))-(x + Scl(14), y + Scl(28)), GorD&
    END SELECT
  NEXT i
END SUB

'ExplodeGorilla:
'  Causes gorilla explosion when a direct hit occurs
'Parameters:
'  X#, Y# - shot location
FUNCTION ExplodeGorilla (x#, y#)
  YAdj = Scl(12)
  XAdj = Scl(5)
  SclX# = ScrWidth / 320
  SclY# = ScrHeight / 200
  IF x# < ScrWidth / 2 THEN PlayerHit = 1 ELSE PlayerHit = 2
  PLAY "MBO0L16EFGEFDC"

  FOR i = 1 TO 8 * SclX#
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), i, ExplosionColor, , , -1.57
    LINE (GorillaX(PlayerHit) + 7 * SclX#, GorillaY(PlayerHit) + 9 * SclY# - i)-(GorillaX(PlayerHit), GorillaY(PlayerHit) + 9 * SclY# - i), ExplosionColor
  NEXT i

  FOR i = 1 TO 16 * SclX#
    IF i < (8 * SclX#) THEN CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + 7 * SclY# + YAdj), (8 * SclX# + 1) - i, BACKATTR, , , -1.57
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, i MOD 2 + 1, , , -1.57
  NEXT i

  FOR i = 24 * SclX# TO 1 STEP -1
    CIRCLE (GorillaX(PlayerHit) + 3.5 * SclX# + XAdj, GorillaY(PlayerHit) + YAdj), i, BACKATTR, , , -1.57
    FOR Count = 1 TO 200
    NEXT
  NEXT i

  ExplodeGorilla = PlayerHit
END FUNCTION

'GetInputs:
'  Gets user inputs at beginning of game
'Parameters:
'  Player1$, Player2$ - player names
'  NumGames - number of games to play
SUB GetInputs (Player1$, Player2$, NumGames)
  COLOR 7, 0
  CLS

  LOCATE 8, 15
  LINE INPUT "Name of Player 1 (Default = 'Player 1'): "; Player1$
  IF Player1$ = "" THEN
    Player1$ = "Player 1"
  ELSE
    Player1$ = LEFT$(Player1$, 10)
  END IF

  LOCATE 10, 15
  LINE INPUT "Name of Player 2 (Default = 'Player 2'): "; Player2$
  IF Player2$ = "" THEN
    Player2$ = "Player 2"
  ELSE
    Player2$ = LEFT$(Player2$, 10)
  END IF

  DO
    LOCATE 12, 56: PRINT SPACE$(25);
    LOCATE 12, 13
    INPUT "Play to how many total points (Default = 3)"; game$
    NumGames = VAL(LEFT$(game$, 2))
  LOOP UNTIL NumGames > 0 AND LEN(game$) < 3 OR LEN(game$) = 0
  IF NumGames = 0 THEN NumGames = 3

  DO
    LOCATE 14, 53: PRINT SPACE$(28);
    LOCATE 14, 17
    INPUT "Gravity in Meters/Sec (Earth = 9.8)"; grav$
    gravity# = VAL(grav$)
  LOOP UNTIL gravity# > 0 OR LEN(grav$) = 0
  IF gravity# = 0 THEN gravity# = 9.8
END SUB

'GetNum:
'  Gets valid numeric input from user
'Parameters:
'  Row, Col - location to echo input
FUNCTION GetNum# (Row, Col)
  Result$ = ""
  Done = FALSE
  WHILE INKEY$ <> "": WEND   'Clear keyboard buffer

  DO WHILE NOT Done

    LOCATE Row, Col
    PRINT Result$; CHR$(95); "    ";

    Kbd$ = INKEY$
    SELECT CASE Kbd$
      CASE "0" TO "9"
        Result$ = Result$ + Kbd$
      CASE "."
        IF INSTR(Result$, ".") = 0 THEN
          Result$ = Result$ + Kbd$
        END IF
      CASE CHR$(13)
        IF VAL(Result$) > 360 THEN
          Result$ = ""
        ELSE
          Done = TRUE
        END IF
      CASE CHR$(8)
        IF LEN(Result$) > 0 THEN
          Result$ = LEFT$(Result$, LEN(Result$) - 1)
        END IF
      CASE ELSE
        IF LEN(Kbd$) > 0 THEN
          BEEP
        END IF
      END SELECT
  LOOP

  LOCATE Row, Col
  PRINT Result$; " ";

  GetNum# = VAL(Result$)
END FUNCTION

'GorillaIntro:
'  Displays gorillas on screen for the first time
'  allows the graphical data to be put into an array
'Parameters:
'  Player1$, Player2$ - The names of the players
'
SUB GorillaIntro (Player1$, Player2$)
  LOCATE 16, 34: PRINT "--------------"
  LOCATE 18, 34: PRINT "V = View Intro"
  LOCATE 19, 34: PRINT "P = Play Game"
  LOCATE 21, 35: PRINT "Your Choice?"

  DO WHILE Char$ = ""
    Char$ = INKEY$
  LOOP

  IF Mode = 1 THEN
    x = 125
    y = 100
  ELSE
    x = 278
    y = 175
  END IF

  SCREEN Mode
  SetScreen

  IF Mode = 1 THEN Center 5, "Please wait while gorillas are drawn."

  VIEW PRINT 9 TO 24

  IF Mode = 9 THEN PALETTE OBJECTCOLOR, BackColor

  DrawGorilla x, y, ARMSDOWN
  CLS 2
  DrawGorilla x, y, LEFTUP
  CLS 2
  DrawGorilla x, y, RIGHTUP
  CLS 2

  VIEW PRINT 1 TO 25
  IF Mode = 9 THEN PALETTE OBJECTCOLOR, 46

  IF UCASE$(Char$) = "V" THEN
    Center 2, "Q B A S I C   G O R I L L A S"
    Center 5, "             STARRING:               "
    P$ = Player1$ + " AND " + Player2$
    Center 7, P$

    PUT (x - 13, y), GorD&, PSET
    PUT (x + 47, y), GorD&, PSET
    Rest 1

    PUT (x - 13, y), GorL&, PSET
    PUT (x + 47, y), GorR&, PSET
    PLAY "t120o1l16b9n0baan0bn0bn0baaan0b9n0baan0b"
    Rest .3

    PUT (x - 13, y), GorR&, PSET
    PUT (x + 47, y), GorL&, PSET
    PLAY "o2l16e-9n0e-d-d-n0e-n0e-n0e-d-d-d-n0e-9n0e-d-d-n0e-"
    Rest .3

    PUT (x - 13, y), GorL&, PSET
    PUT (x + 47, y), GorR&, PSET
    PLAY "o2l16g-9n0g-een0g-n0g-n0g-eeen0g-9n0g-een0g-"
    Rest .3

    PUT (x - 13, y), GorR&, PSET
    PUT (x + 47, y), GorL&, PSET
    PLAY "o2l16b9n0baan0g-n0g-n0g-eeen0o1b9n0baan0b"
    Rest .3

    FOR i = 1 TO 4
      PUT (x - 13, y), GorL&, PSET
      PUT (x + 47, y), GorR&, PSET
      PLAY "T160O0L32EFGEFDC"
      Rest .1
      PUT (x - 13, y), GorR&, PSET
      PUT (x + 47, y), GorL&, PSET
      PLAY "T160O0L32EFGEFDC"
      Rest .1
    NEXT
  END IF
END SUB

'Intro:
'  Displays game introduction
SUB Intro

  SCREEN 0
  WIDTH 80, 25
  MaxCol = 80
  COLOR 15, 0
  CLS

  Center 4, "Q B a s i c    G O R I L L A S"
  COLOR 7
  Center 6, "Copyright (C) IBM Corporation 1991"
  Center 8, "Your mission is to hit your opponent with the exploding"
  Center 9, "banana by varying the angle and power of your throw, taking"
  Center 10, "into account wind speed, gravity, and the city skyline."
  Center 11, "The wind speed is shown by a directional arrow at the bottom"
  Center 12, "of the playing field, its length relative to its strength."
  Center 24, "Press any key to continue"

  PLAY "MBT160O1L8CDEDCDL4ECC"
  SparklePause
  IF Mode = 1 THEN MaxCol = 40
END SUB

'MakeCityScape:
'  Creates random skyline for game
'Parameters:
'  BCoor() - a user-defined type array which stores the coordinates of
'  the upper left corner of each building.
SUB MakeCityScape (BCoor() AS XYPoint)

  x = 2

  'Set the sloping trend of the city scape. NewHt is new building height
  Slope = FnRan(6)
  SELECT CASE Slope
    CASE 1: NewHt = 15                 'Upward slope
    CASE 2: NewHt = 130                'Downward slope
    CASE 3 TO 5: NewHt = 15            '"V" slope - most common
    CASE 6: NewHt = 130                'Inverted "V" slope
  END SELECT

  IF Mode = 9 THEN
    BottomLine = 335                   'Bottom of building
    HtInc = 10                         'Increase value for new height
    DefBWidth = 37                     'Default building height
    RandomHeight = 120                 'Random height difference
    WWidth = 3                         'Window width
    WHeight = 6                        'Window height
    WDifV = 15                         'Counter for window spacing - vertical
    WDifh = 10                         'Counter for window spacing - horizontal
  ELSE
    BottomLine = 190
    HtInc = 6
    NewHt = NewHt * 20 \ 35            'Adjust for CGA
    DefBWidth = 18
    RandomHeight = 54
    WWidth = 1
    WHeight = 2
    WDifV = 5
    WDifh = 4
  END IF

  CurBuilding = 1
  DO

    SELECT CASE Slope
      CASE 1
        NewHt = NewHt + HtInc
      CASE 2
        NewHt = NewHt - HtInc
      CASE 3 TO 5
        IF x > ScrWidth \ 2 THEN
          NewHt = NewHt - 2 * HtInc
        ELSE
          NewHt = NewHt + 2 * HtInc
        END IF
      CASE 4
        IF x > ScrWidth \ 2 THEN
          NewHt = NewHt + 2 * HtInc
        ELSE
          NewHt = NewHt - 2 * HtInc
        END IF
    END SELECT

    'Set width of building and check to see if it would go off the screen
    BWidth = FnRan(DefBWidth) + DefBWidth
    IF x + BWidth > ScrWidth THEN BWidth = ScrWidth - x - 2

    'Set height of building and check to see if it goes below screen
    BHeight = FnRan(RandomHeight) + NewHt
    IF BHeight < HtInc THEN BHeight = HtInc

    'Check to see if Building is too high
    IF BottomLine - BHeight <= MaxHeight + GHeight THEN BHeight = MaxHeight + GHeight - 5

    'Set the coordinates of the building into the array
    BCoor(CurBuilding).XCoor = x
    BCoor(CurBuilding).YCoor = BottomLine - BHeight

    IF Mode = 9 THEN BuildingColor = FnRan(3) + 4 ELSE BuildingColor = 2

    'Draw the building, outline first, then filled
    LINE (x - 1, BottomLine + 1)-(x + BWidth + 1, BottomLine - BHeight - 1), BACKGROUND, B
    LINE (x, BottomLine)-(x + BWidth, BottomLine - BHeight), BuildingColor, BF

    'Draw the windows
    c = x + 3
    DO
      FOR i = BHeight - 3 TO 7 STEP -WDifV
        IF Mode <> 9 THEN
          WinColr = (FnRan(2) - 2) * -3
        ELSEIF FnRan(4) = 1 THEN
          WinColr = 8
        ELSE
          WinColr = WINDOWCOLOR
        END IF
        LINE (c, BottomLine - i)-(c + WWidth, BottomLine - i + WHeight), WinColr, BF
      NEXT
      c = c + WDifh
    LOOP UNTIL c >= x + BWidth - 3

    x = x + BWidth + 2

    CurBuilding = CurBuilding + 1

  LOOP UNTIL x > ScrWidth - HtInc

  LastBuilding = CurBuilding - 1

  'Set Wind speed
  Wind = FnRan(10) - 5
  IF FnRan(3) = 1 THEN
    IF Wind > 0 THEN
      Wind = Wind + FnRan(10)
    ELSE
      Wind = Wind - FnRan(10)
    END IF
  END IF

  'Draw Wind speed arrow
  IF Wind <> 0 THEN
    WindLine = Wind * 3 * (ScrWidth \ 320)
    LINE (ScrWidth \ 2, ScrHeight - 5)-(ScrWidth \ 2 + WindLine, ScrHeight - 5), ExplosionColor
    IF Wind > 0 THEN ArrowDir = -2 ELSE ArrowDir = 2
    LINE (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 - 2), ExplosionColor
    LINE (ScrWidth / 2 + WindLine, ScrHeight - 5)-(ScrWidth / 2 + WindLine + ArrowDir, ScrHeight - 5 + 2), ExplosionColor
  END IF
END SUB

'PlaceGorillas:
'  PUTs the Gorillas on top of the buildings.  Must have drawn
'  Gorillas first.
'Parameters:
'  BCoor() - user-defined TYPE array which stores upper left coordinates
'  of each building.
SUB PlaceGorillas (BCoor() AS XYPoint)

  IF Mode = 9 THEN
    XAdj = 14
    YAdj = 30
  ELSE
    XAdj = 7
    YAdj = 16
  END IF
  SclX# = ScrWidth / 320
  SclY# = ScrHeight / 200

  'Place gorillas on second or third building from edge
  FOR i = 1 TO 2
    IF i = 1 THEN BNum = FnRan(2) + 1 ELSE BNum = LastBuilding - FnRan(2)

    BWidth = BCoor(BNum + 1).XCoor - BCoor(BNum).XCoor
    GorillaX(i) = BCoor(BNum).XCoor + BWidth / 2 - XAdj
    GorillaY(i) = BCoor(BNum).YCoor - YAdj
    PUT (GorillaX(i), GorillaY(i)), GorD&, PSET
  NEXT i

END SUB

'PlayGame:
'  Main game play routine
'Parameters:
'  Player1$, Player2$ - player names
'  NumGames - number of games to play
SUB PlayGame (Player1$, Player2$, NumGames)
  DIM BCoor(0 TO 30) AS XYPoint
  DIM TotalWins(1 TO 2)

  J = 1

  FOR i = 1 TO NumGames

    CLS
    RANDOMIZE (TIMER)
    CALL MakeCityScape(BCoor())
    CALL PlaceGorillas(BCoor())
    DoSun SUNHAPPY
    Hit = FALSE
    DO WHILE Hit = FALSE
      J = 1 - J
      LOCATE 1, 1
      PRINT Player1$
      LOCATE 1, (MaxCol - 1 - LEN(Player2$))
      PRINT Player2$
      Center 23, LTRIM$(STR$(TotalWins(1))) + ">Score<" + LTRIM$(STR$(TotalWins(2)))
      Tosser = J + 1: Tossee = 3 - J

      'Plot the shot.  Hit is true if Gorilla gets hit.
      Hit = DoShot(Tosser, GorillaX(Tosser), GorillaY(Tosser))

      'Reset the sun, if it got hit
      IF SunHit THEN DoSun SUNHAPPY

      IF Hit = TRUE THEN CALL UpdateScores(TotalWins(), Tosser, Hit)
    LOOP
    SLEEP 1
  NEXT i

  SCREEN 0
  WIDTH 80, 25
  COLOR 7, 0
  MaxCol = 80
  CLS

  Center 8, "GAME OVER!"
  Center 10, "Score:"
  LOCATE 11, 30: PRINT Player1$; TAB(50); TotalWins(1)
  LOCATE 12, 30: PRINT Player2$; TAB(50); TotalWins(2)
  Center 24, "Press any key to continue"
  SparklePause
  COLOR 7, 0
  CLS
END SUB

'PlayGame:
'  Plots banana shot across the screen
'Parameters:
'  StartX, StartY - starting shot location
'  Angle - shot angle
'  Velocity - shot velocity
'  PlayerNum - the banana thrower
FUNCTION PlotShot (StartX, StartY, Angle#, Velocity, PlayerNum)

  Angle# = Angle# / 180 * pi#  'Convert degree angle to radians
  Radius = Mode MOD 7

  InitXVel# = COS(Angle#) * Velocity
  InitYVel# = SIN(Angle#) * Velocity

  oldx# = StartX
  oldy# = StartY

  'draw gorilla toss
  IF PlayerNum = 1 THEN
    PUT (StartX, StartY), GorL&, PSET
  ELSE
    PUT (StartX, StartY), GorR&, PSET
  END IF

  'throw sound
  PLAY "MBo0L32A-L64CL16BL64A+"
  Rest .1

  'redraw gorilla
  PUT (StartX, StartY), GorD&, PSET

  adjust = Scl(4)                   'For scaling CGA

  xedge = Scl(9) * (2 - PlayerNum)  'Find leading edge of banana for check

  Impact = FALSE
  ShotInSun = FALSE
  OnScreen = TRUE
  PlayerHit = 0
  NeedErase = FALSE

  StartXPos = StartX
  StartYPos = StartY - adjust - 3

  IF PlayerNum = 2 THEN
    StartXPos = StartXPos + Scl(25)
    direction = Scl(4)
  ELSE
    direction = Scl(-4)
  END IF

  IF Velocity < 2 THEN              'Shot too slow - hit self
    x# = StartX
    y# = StartY
    pointval = OBJECTCOLOR
  END IF

  DO WHILE (NOT Impact) AND OnScreen

  Rest .02

  'Erase old banana, if necessary
  IF NeedErase THEN
    NeedErase = FALSE
    CALL DrawBan(oldx#, oldy#, oldrot, FALSE)
  END IF

  x# = StartXPos + (InitXVel# * t#) + (.5 * (Wind / 5) * t# ^ 2)
  y# = StartYPos + ((-1 * (InitYVel# * t#)) + (.5 * gravity# * t# ^ 2)) * (ScrHeight / 350)

  IF (x# >= ScrWidth - Scl(10)) OR (x# <= 3) OR (y# >= ScrHeight - 3) THEN
    OnScreen = FALSE
  END IF


  IF OnScreen AND y# > 0 THEN

    'check it
    LookY = 0
    LookX = Scl(8 * (2 - PlayerNum))
    DO
      pointval = POINT(x# + LookX, y# + LookY)
      IF pointval = 0 THEN
        Impact = FALSE
        IF ShotInSun = TRUE THEN
          IF ABS(ScrWidth \ 2 - x#) > Scl(20) OR y# > SunHt THEN ShotInSun = FALSE
        END IF
      ELSEIF pointval = SUNATTR AND y# < SunHt THEN
        IF NOT SunHit THEN DoSun SUNSHOCK
        SunHit = TRUE
        ShotInSun = TRUE
      ELSE
        Impact = TRUE
      END IF
      LookX = LookX + direction
      LookY = LookY + Scl(6)
    LOOP UNTIL Impact OR LookX <> Scl(4)

    IF NOT ShotInSun AND NOT Impact THEN
      'plot it
      rot = (t# * 10) MOD 4
      CALL DrawBan(x#, y#, rot, TRUE)
      NeedErase = TRUE
    END IF

    oldx# = x#
    oldy# = y#
    oldrot = rot

  END IF


  t# = t# + .1

  LOOP

  IF pointval <> OBJECTCOLOR AND Impact THEN
    CALL DoExplosion(x# + adjust, y# + adjust)
  ELSEIF pointval = OBJECTCOLOR THEN
    PlayerHit = ExplodeGorilla(x#, y#)
  END IF

  PlotShot = PlayerHit

END FUNCTION

'Rest:
'  pauses the program
SUB Rest (t#)
  s# = TIMER
  t2# = MachSpeed * t# / SPEEDCONST
  DO
  LOOP UNTIL TIMER - s# > t2#
END SUB

'Scl:
'  Pass the number in to scaling for cga.  If the number is a decimal, then we
'  want to scale down for cga or scale up for ega.  This allows a full range
'  of numbers to be generated for scaling.
'  (i.e. for 3 to get scaled to 1, pass in 2.9)
FUNCTION Scl (n!)

  IF n! <> INT(n!) THEN
      IF Mode = 1 THEN n! = n! - 1
  END IF
  IF Mode = 1 THEN
      Scl = CINT(n! / 2 + .1)
  ELSE
      Scl = CINT(n!)
  END IF

END FUNCTION

'SetScreen:
'  Sets the appropriate color statements
SUB SetScreen

  IF Mode = 9 THEN
    ExplosionColor = 2
    BackColor = 1
    PALETTE 0, 1
    PALETTE 1, 46
    PALETTE 2, 44
    PALETTE 3, 54
    PALETTE 5, 7
    PALETTE 6, 4
    PALETTE 7, 3
    PALETTE 9, 63       'Display Color
  ELSE
    ExplosionColor = 2
    BackColor = 0
    COLOR BackColor, 2

  END IF

END SUB

'SparklePause:
'  Creates flashing border for intro and game over screens
SUB SparklePause

  COLOR 4, 0
  A$ = "*    *    *    *    *    *    *    *    *    *    *    *    *    *    *    *    *    "
  WHILE INKEY$ <> "": WEND 'Clear keyboard buffer

  WHILE INKEY$ = ""
    FOR A = 1 TO 5
      LOCATE 1, 1                             'print horizontal sparkles
      PRINT MID$(A$, A, 80);
      LOCATE 22, 1
      PRINT MID$(A$, 6 - A, 80);

      FOR b = 2 TO 21                         'Print Vertical sparkles
        c = (A + b) MOD 5
        IF c = 1 THEN
          LOCATE b, 80
          PRINT "*";
          LOCATE 23 - b, 1
          PRINT "*";
        ELSE
          LOCATE b, 80
          PRINT " ";
          LOCATE 23 - b, 1
          PRINT " ";
        END IF
      NEXT b
    NEXT A
  WEND
END SUB

'UpdateScores:
'  Updates players' scores
'Parameters:
'  Record - players' scores
'  PlayerNum - player
'  Results - results of player's shot
SUB UpdateScores (Record(), PlayerNum, Results)
  IF Results = HITSELF THEN
    Record(ABS(PlayerNum - 3)) = Record(ABS(PlayerNum - 3)) + 1
  ELSE
    Record(PlayerNum) = Record(PlayerNum) + 1
  END IF
END SUB

'VictoryDance:
'  gorilla dances after he has eliminated his opponent
'Parameters:
'  Player - which gorilla is dancing
SUB VictoryDance (Player)

  FOR i# = 1 TO 4
    PUT (GorillaX(Player), GorillaY(Player)), GorL&, PSET
    PLAY "MFO0L32EFGEFDC"
    Rest .2
    PUT (GorillaX(Player), GorillaY(Player)), GorR&, PSET
    PLAY "MFO0L32EFGEFDC"
    Rest .2
  NEXT
END SUB

Attachments


GORILAS.jpg (205.15 KiB)


GORILA-V2.jpg (241.89 KiB)


GORILA-V1.jpg (221.43 KiB)

GORILA.rar (144.71 KiB)
]]> <![CDATA[General :: Re: Imagen persiste al final :: Reply by LOUIS]]> 2024-11-01T20:16:51+00:00 2024-11-01T20:16:51+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7606&p=71390#p71390
I Added the sun to the picture ...

I have not advanced any further, waiting for you to give me a hand or an idea, so as not to do double work.

Saludos
Louis

Code: Select all

DO EDIFICIOS
@ 0,650 IMAGE SOL PICTURE "SOL.JPG" WIDTH 50 HEIGHT 50 STRETCH
DO GORILA

Attachments

SOL.rar (2.76 KiB)

GORILAS-NEW.jpg (205.9 KiB)

]]>
I Added the sun to the picture ...

I have not advanced any further, waiting for you to give me a hand or an idea, so as not to do double work.

Saludos
Louis

Code: Select all

DO EDIFICIOS
@ 0,650 IMAGE SOL PICTURE "SOL.JPG" WIDTH 50 HEIGHT 50 STRETCH
DO GORILA

Attachments

SOL.rar (2.76 KiB)

GORILAS-NEW.jpg (205.9 KiB)

]]> <![CDATA[General :: PERINOLA'S GAME :: Author LOUIS]]> 2024-11-10T11:42:52+00:00 2024-11-10T11:42:52+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7620&p=71400#p71400
Os comparto un jueguito llamado La Perinola, espero lo hayan conocido, era como un trompito que tenía 4 lados o más, que jugamos de niños.
Quizás mi forma de programar es rústica, pero funciona ... En la primera pantalla aparecen las instrucciones, luego aparecerá una imagen de las perinolas en la cual deberán dar click y por último saldrá la pantalla del juego la cual estará en pausa.
Se activa el juego pulsando cualquier tecla direccional y se detiene pulsando Enter, con Esc sale del juego.
Va acompañada de una dbf necesaria para el juego, que por cierto debe jugarse entre 2 personas o más.
Cuando se pulsa Enter, aparecerá una de estas 4 palabras: SACA - TODO - PONE -y- NADA las cuales están explicadas en la primera pantalla de introducción.
Espero que os guste y como siempre digo, si alguien quiere mejorarlo, adelante, que esto es para compartir entre todos.

Saludos
Louis

Attachments


PANTA-TODO.jpg (182.23 KiB)


PANTAXXX.jpg (169.7 KiB)


PANTALLA 2.jpg (30.9 KiB)

PERINOLA.rar (444.46 KiB)
]]>
Os comparto un jueguito llamado La Perinola, espero lo hayan conocido, era como un trompito que tenía 4 lados o más, que jugamos de niños.
Quizás mi forma de programar es rústica, pero funciona ... En la primera pantalla aparecen las instrucciones, luego aparecerá una imagen de las perinolas en la cual deberán dar click y por último saldrá la pantalla del juego la cual estará en pausa.
Se activa el juego pulsando cualquier tecla direccional y se detiene pulsando Enter, con Esc sale del juego.
Va acompañada de una dbf necesaria para el juego, que por cierto debe jugarse entre 2 personas o más.
Cuando se pulsa Enter, aparecerá una de estas 4 palabras: SACA - TODO - PONE -y- NADA las cuales están explicadas en la primera pantalla de introducción.
Espero que os guste y como siempre digo, si alguien quiere mejorarlo, adelante, que esto es para compartir entre todos.

Saludos
Louis

Attachments


PANTA-TODO.jpg (182.23 KiB)


PANTAXXX.jpg (169.7 KiB)


PANTALLA 2.jpg (30.9 KiB)

PERINOLA.rar (444.46 KiB)
]]> <![CDATA[General :: Re: PERINOLA'S GAME :: Reply by serge_girard]]> 2024-11-10T19:07:48+00:00 2024-11-10T19:07:48+00:00 http://mail.hmgforum.com/viewtopic.php?f=24&t=7620&p=71401#p71401 <![CDATA[HMG Samples :: 'HMG EasySQL' a Simple SQL HMG library :: Author Roberto Lopez]]> 2024-11-03T20:06:27+00:00 2024-11-03T20:06:27+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71391#p71391
As I've recently commented, the last years I've been working primarily with MySql/MariaDB even for local/LAN-only projects.

I'm using portable MariaDB server. It is fast, compact and requires no configuration. You only must copy it to destination and simply works!.

I've started using rddsql contrib by Mindaugas Kavaliauskas, since it was the best choice for me (I want to have as much control as possible).

After finishing my first project, I've noticed that I could create some functions to make my code easier to write and maintain.

The worst part was 'construct' INSERT and UPDATE commands concatenating strings for tables with lots of columns.

With my functions, the code started to look like this:

Code: Select all

SqlConnect( blah, blah, blah)
SqlInsert(<table>)
SqlField(<name>,<value>)
SqlField(<name>,<value>)
SqlField(<name>,<value>)
SqlExec()
This worked fine, but it only allowed a connection/operation at a time, since design limitations.

So, I needed to upgrade to allow multiple connections at a time.

I've created a little class to handle that.

This is an usage example (CREATE TABLE):

Code: Select all

	WAIT WINDOW 'Processing...' NOWAIT	

	WITH OBJECT SQL():New()

		:Connect(_MYSQL_SERVER_, _MYSQL_USER_, _MYSQL_PASSWORD_, _MYSQL_DATABASE_)

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Exec("DROP TABLE IF EXISTS hmgtest")

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Exec("CREATE TABLE hmgtest (id BIGINT UNSIGNED AUTO_INCREMENT PRIMARY KEY, code INT UNSIGNED UNIQUE, description CHAR(128), location CHAR(128), stock BIGINT UNSIGNED )")

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Disconnect()

	END WITH

	WAIT CLEAR
To insert a row:

Code: Select all

	WAIT WINDOW 'Processing...' NOWAIT

	WITH OBJECT SQL():New()

		:Connect(_MYSQL_SERVER_, _MYSQL_USER_, _MYSQL_PASSWORD_, _MYSQL_DATABASE_)

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Insert('hmgtest')

		:Field('code'        , nCode        )
		:Field('description' , cDescription )
		:Field('location'    , cLocation    )
		:Field('stock'       , nStock       )

		:Exec()

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Disconnect()

	ENDWITH

	WAIT CLEAR
The library handles (or attempts to) all possible error types, hopefully, preventing crashes.

Here is the library (MUST BE CONSIDERED EXPERIMENTAL):

lib.sql.prg

Code: Select all

/*
 * 'HMG EasySQL' a Simple HMG library To Handle MySql/MariaDB 'Things'
 *
 * *** EXPERIMENTAL CODE ***
 *
 * Copyright 2024 Roberto Lopez <mail.box.hmg@gmail.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.txt.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA (or visit the web site https://www.gnu.org/).
 *
 * As a special exception, the Harbour Project gives permission for
 * additional uses of the text contained in its release of Harbour.
 *
 * The exception is that, if you link the Harbour libraries with other
 * files to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the Harbour library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the Harbour
 * Project under the name Harbour.  If you copy code from other
 * Harbour Project or Free Software Foundation releases into a copy of
 * Harbour, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for Harbour, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.
 *
 */


#include 'hmg.ch'

#include 'common.ch'

#xcommand TRY => BEGIN SEQUENCE WITH { |e| break( e ) }
#xcommand CATCH [<!oErr!>] => RECOVER [USING <oErr>] <-oErr->
#xcommand FINALLY => ALWAYS

#include "lib.sql.ch"

#include "hbclass.ch"
#include "common.ch"

REQUEST SDDMY, SQLMIX

*--------------------------------------------------------------------------------------*
CLASS SQL 
*--------------------------------------------------------------------------------------*

	// data: 

	DATA	cCommandBuffer	
	DATA	cCommandWhere		
	DATA	nConnHandle	
	DATA	lError
	DATA	cErrorDesc

	// Methods: 

	METHOD New()
	METHOD Connect(cServer, cUser, cPassword, cDatabase)
	METHOD Use(cCommand,cWorkArea)
	METHOD Disconnect()

	METHOD Close(cWorkArea)
	METHOD Delete(cTable,cWhere)

	METHOD AffectedRows() 
	METHOD StartTransaction()
	METHOD Commit() 
	METHOD Rollback()
	METHOD Exec()

	METHOD Insert(cTable)
	METHOD Update(cTable,cWhere)
	METHOD Field(cField,xExpression,lRaw)

ENDCLASS

*--------------------------------------------------------------------------------------*
METHOD Close(cWorkArea) CLASS SQL
*--------------------------------------------------------------------------------------*

	CLOSE &cWorkArea

RETURN NIL

*--------------------------------------------------------------------------------------*
METHOD New() CLASS SQL
*--------------------------------------------------------------------------------------*

	::cCommandBuffer	:= ''
	::cCommandWhere		:= '' 
	::nConnHandle		:= 0
	::lError		:= .F.
	::cErrorDesc		:= ''

RETURN Self

*--------------------------------------------------------------------------------------*
METHOD Connect(cServer, cUser, cPassword, cDatabase) CLASS SQL
*--------------------------------------------------------------------------------------*

	::nConnHandle := RDDINFO(RDDI_CONNECT, {"MYSQL", cServer, cUser, cPassword, cDatabase }, "SQLMIX" ) 

	IF VALTYPE(::nConnHandle) <> 'N'

		::nConnHandle := 0

	ENDIF

	IF ::nConnHandle == 0
		::lError	:= .T.
		::cErrorDesc	:= 'Connection Error!'
	ENDIF

RETURN ::nConnHandle

*--------------------------------------------------------------------------------------*
METHOD Disconnect() CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL nRetVal
        
	nRetVal := RDDINFO( RDDI_DISCONNECT,,,::nConnHandle )

	IF valtype(nRetVal) <> 'N'
		nRetVal := 0
	ENDIF

RETURN nRetVal

*--------------------------------------------------------------------------------------*
METHOD Use(cCommand, cWorkArea) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL oError

	TRY

		DBUSEAREA( .T.,"SQLMIX", cCommand, cWorkArea,,,,::nConnHandle )

		::lError	:= .F.

	CATCH oError

		::lError	:= .T.
		::cErrorDesc	:= oError:Description

	END

RETURN 

*--------------------------------------------------------------------------------------*
METHOD Field(cField,xExpression,lRaw) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL cExpression


	DEFAULT lRaw TO .F.

	IF VALTYPE(xExpression) = 'D'
		cExpression := STRZERO(YEAR(xExpression),4) + '-' + STRZERO(MONTH(xExpression),2) + '-' + STRZERO(DAY(xExpression),2)
	ELSEIF VALTYPE(xExpression) = 'C'
		cExpression := alltrim(xExpression)
	ELSEIF VALTYPE(xExpression) = 'N'
		cExpression := alltrim(str(xExpression))
	ELSEIF VALTYPE(xExpression) = 'L'
		IF xExpression
			cExpression := '1'
		ELSE
			cExpression := '0'
		ENDIF
	ELSE
		::lError	:= .T.
		::cErrorDesc	:= 'SqlField: Expression Type Error!'
		RETURN
	ENDIF

	IF "'" $ cExpression 
		cExpression := StrTran(cExpression, "'" , "´")
	ENDIF

	IF lRaw

		::cCommandBuffer += cField + " = " + cExpression + ' ' + ','

	ELSE

		::cCommandBuffer += cField + " = " + "'" + cExpression + "'" + ','

	ENDIF

RETURN 

*--------------------------------------------------------------------------------------*
METHOD Insert(cTable) CLASS SQL
*--------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "INSERT INTO " +  cTable + " SET " 		

RETURN

*------------------------------------------------------------------------------------------*
METHOD Delete(cTable,cWhere) CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "DELETE FROM " +  cTable + " WHERE " + cWhere

	::Exec()

RETURN

*----------------------------------------------------------------------------------------------
METHOD AffectedRows() CLASS SQL
*----------------------------------------------------------------------------------------------
LOCAL nRetVal
        
	nRetVal := RDDINFO( RDDI_AFFECTEDROWS,,,::nConnHandle )

	IF valtype(nRetVal) <> 'N'
		nRetVal := 0
	ENDIF

RETURN nRetVal

*------------------------------------------------------------------------------------------*
METHOD StartTransaction() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "START TRANSACTION" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Commit() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "COMMIT" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Rollback() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "ROLLBACK" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Update(cTable,cWhere) CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''

	::cCommandWhere := cWhere

	::cCommandBuffer += "UPDATE " +  cTable + " SET " 		

RETURN

*--------------------------------------------------------------------------------------*
METHOD Exec(cCommand) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL cRDD

	cRDD := RDDSETDEFAULT()

	RDDSETDEFAULT("SQLMIX")

	IF ValType(cCommand) = 'U' 

		IF Right( ::cCommandBuffer , 1 ) == ','

			::cCommandBuffer := LEFT( ::cCommandBuffer , LEN(::cCommandBuffer) - 1 )

		ENDIF

		IF .NOT. Empty(::cCommandWhere) 

			::cCommandBuffer += 'WHERE ' + ::cCommandWhere

		ENDIF

		::lError := .NOT. RDDINFO( RDDI_EXECUTE, ::cCommandBuffer , , ::nConnHandle )

		HB_MEMOWRIT( 'trace.log' , ::cCommandBuffer , .f. )

	ELSE

		HB_MEMOWRIT( 'trace.log' , cCommand , .f. )

		::lError := .NOT. RDDINFO( RDDI_EXECUTE, cCommand, , ::nConnHandle )

	ENDIF

	IF ValType(::lError) <> 'L'
		::lError := .T.
	ENDIF

	IF ::lError
		::cErrorDesc := rddinfo(RDDI_ERROR,,,::nConnHandle )
	else
		::cErrorDesc := ''
	ENDIF

	::cCommandBuffer := ''

	RDDSETDEFAULT(cRDD)

RETURN
lib.sql.ch

Code: Select all

#define RDDI_CONNECT          1001
#define RDDI_DISCONNECT       1002
#define RDDI_EXECUTE          1003
#define RDDI_ERROR            1004
#define RDDI_ERRORNO          1005
#define RDDI_NEWID            1006
#define RDDI_AFFECTEDROWS     1007
#define RDDI_QUERY            1008
Attached to this message is the library with a full example.

All this thing must be considered experimental.

I hope it be useful for someone.

Attachments

HMG EasySql Library
hmg.easy.sql.zip (1774.69 KiB)
]]>
As I've recently commented, the last years I've been working primarily with MySql/MariaDB even for local/LAN-only projects.

I'm using portable MariaDB server. It is fast, compact and requires no configuration. You only must copy it to destination and simply works!.

I've started using rddsql contrib by Mindaugas Kavaliauskas, since it was the best choice for me (I want to have as much control as possible).

After finishing my first project, I've noticed that I could create some functions to make my code easier to write and maintain.

The worst part was 'construct' INSERT and UPDATE commands concatenating strings for tables with lots of columns.

With my functions, the code started to look like this:

Code: Select all

SqlConnect( blah, blah, blah)
SqlInsert(<table>)
SqlField(<name>,<value>)
SqlField(<name>,<value>)
SqlField(<name>,<value>)
SqlExec()
This worked fine, but it only allowed a connection/operation at a time, since design limitations.

So, I needed to upgrade to allow multiple connections at a time.

I've created a little class to handle that.

This is an usage example (CREATE TABLE):

Code: Select all

	WAIT WINDOW 'Processing...' NOWAIT	

	WITH OBJECT SQL():New()

		:Connect(_MYSQL_SERVER_, _MYSQL_USER_, _MYSQL_PASSWORD_, _MYSQL_DATABASE_)

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Exec("DROP TABLE IF EXISTS hmgtest")

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Exec("CREATE TABLE hmgtest (id BIGINT UNSIGNED AUTO_INCREMENT PRIMARY KEY, code INT UNSIGNED UNIQUE, description CHAR(128), location CHAR(128), stock BIGINT UNSIGNED )")

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Disconnect()

	END WITH

	WAIT CLEAR
To insert a row:

Code: Select all

	WAIT WINDOW 'Processing...' NOWAIT

	WITH OBJECT SQL():New()

		:Connect(_MYSQL_SERVER_, _MYSQL_USER_, _MYSQL_PASSWORD_, _MYSQL_DATABASE_)

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Insert('hmgtest')

		:Field('code'        , nCode        )
		:Field('description' , cDescription )
		:Field('location'    , cLocation    )
		:Field('stock'       , nStock       )

		:Exec()

		IF :lError
			WAIT CLEAR
			MsgStop(:cErrorDesc)
			RETURN
		ENDIF

		:Disconnect()

	ENDWITH

	WAIT CLEAR
The library handles (or attempts to) all possible error types, hopefully, preventing crashes.

Here is the library (MUST BE CONSIDERED EXPERIMENTAL):

lib.sql.prg

Code: Select all

/*
 * 'HMG EasySQL' a Simple HMG library To Handle MySql/MariaDB 'Things'
 *
 * *** EXPERIMENTAL CODE ***
 *
 * Copyright 2024 Roberto Lopez <mail.box.hmg@gmail.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.txt.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA (or visit the web site https://www.gnu.org/).
 *
 * As a special exception, the Harbour Project gives permission for
 * additional uses of the text contained in its release of Harbour.
 *
 * The exception is that, if you link the Harbour libraries with other
 * files to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the Harbour library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the Harbour
 * Project under the name Harbour.  If you copy code from other
 * Harbour Project or Free Software Foundation releases into a copy of
 * Harbour, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for Harbour, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.
 *
 */


#include 'hmg.ch'

#include 'common.ch'

#xcommand TRY => BEGIN SEQUENCE WITH { |e| break( e ) }
#xcommand CATCH [<!oErr!>] => RECOVER [USING <oErr>] <-oErr->
#xcommand FINALLY => ALWAYS

#include "lib.sql.ch"

#include "hbclass.ch"
#include "common.ch"

REQUEST SDDMY, SQLMIX

*--------------------------------------------------------------------------------------*
CLASS SQL 
*--------------------------------------------------------------------------------------*

	// data: 

	DATA	cCommandBuffer	
	DATA	cCommandWhere		
	DATA	nConnHandle	
	DATA	lError
	DATA	cErrorDesc

	// Methods: 

	METHOD New()
	METHOD Connect(cServer, cUser, cPassword, cDatabase)
	METHOD Use(cCommand,cWorkArea)
	METHOD Disconnect()

	METHOD Close(cWorkArea)
	METHOD Delete(cTable,cWhere)

	METHOD AffectedRows() 
	METHOD StartTransaction()
	METHOD Commit() 
	METHOD Rollback()
	METHOD Exec()

	METHOD Insert(cTable)
	METHOD Update(cTable,cWhere)
	METHOD Field(cField,xExpression,lRaw)

ENDCLASS

*--------------------------------------------------------------------------------------*
METHOD Close(cWorkArea) CLASS SQL
*--------------------------------------------------------------------------------------*

	CLOSE &cWorkArea

RETURN NIL

*--------------------------------------------------------------------------------------*
METHOD New() CLASS SQL
*--------------------------------------------------------------------------------------*

	::cCommandBuffer	:= ''
	::cCommandWhere		:= '' 
	::nConnHandle		:= 0
	::lError		:= .F.
	::cErrorDesc		:= ''

RETURN Self

*--------------------------------------------------------------------------------------*
METHOD Connect(cServer, cUser, cPassword, cDatabase) CLASS SQL
*--------------------------------------------------------------------------------------*

	::nConnHandle := RDDINFO(RDDI_CONNECT, {"MYSQL", cServer, cUser, cPassword, cDatabase }, "SQLMIX" ) 

	IF VALTYPE(::nConnHandle) <> 'N'

		::nConnHandle := 0

	ENDIF

	IF ::nConnHandle == 0
		::lError	:= .T.
		::cErrorDesc	:= 'Connection Error!'
	ENDIF

RETURN ::nConnHandle

*--------------------------------------------------------------------------------------*
METHOD Disconnect() CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL nRetVal
        
	nRetVal := RDDINFO( RDDI_DISCONNECT,,,::nConnHandle )

	IF valtype(nRetVal) <> 'N'
		nRetVal := 0
	ENDIF

RETURN nRetVal

*--------------------------------------------------------------------------------------*
METHOD Use(cCommand, cWorkArea) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL oError

	TRY

		DBUSEAREA( .T.,"SQLMIX", cCommand, cWorkArea,,,,::nConnHandle )

		::lError	:= .F.

	CATCH oError

		::lError	:= .T.
		::cErrorDesc	:= oError:Description

	END

RETURN 

*--------------------------------------------------------------------------------------*
METHOD Field(cField,xExpression,lRaw) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL cExpression


	DEFAULT lRaw TO .F.

	IF VALTYPE(xExpression) = 'D'
		cExpression := STRZERO(YEAR(xExpression),4) + '-' + STRZERO(MONTH(xExpression),2) + '-' + STRZERO(DAY(xExpression),2)
	ELSEIF VALTYPE(xExpression) = 'C'
		cExpression := alltrim(xExpression)
	ELSEIF VALTYPE(xExpression) = 'N'
		cExpression := alltrim(str(xExpression))
	ELSEIF VALTYPE(xExpression) = 'L'
		IF xExpression
			cExpression := '1'
		ELSE
			cExpression := '0'
		ENDIF
	ELSE
		::lError	:= .T.
		::cErrorDesc	:= 'SqlField: Expression Type Error!'
		RETURN
	ENDIF

	IF "'" $ cExpression 
		cExpression := StrTran(cExpression, "'" , "´")
	ENDIF

	IF lRaw

		::cCommandBuffer += cField + " = " + cExpression + ' ' + ','

	ELSE

		::cCommandBuffer += cField + " = " + "'" + cExpression + "'" + ','

	ENDIF

RETURN 

*--------------------------------------------------------------------------------------*
METHOD Insert(cTable) CLASS SQL
*--------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "INSERT INTO " +  cTable + " SET " 		

RETURN

*------------------------------------------------------------------------------------------*
METHOD Delete(cTable,cWhere) CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "DELETE FROM " +  cTable + " WHERE " + cWhere

	::Exec()

RETURN

*----------------------------------------------------------------------------------------------
METHOD AffectedRows() CLASS SQL
*----------------------------------------------------------------------------------------------
LOCAL nRetVal
        
	nRetVal := RDDINFO( RDDI_AFFECTEDROWS,,,::nConnHandle )

	IF valtype(nRetVal) <> 'N'
		nRetVal := 0
	ENDIF

RETURN nRetVal

*------------------------------------------------------------------------------------------*
METHOD StartTransaction() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "START TRANSACTION" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Commit() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "COMMIT" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Rollback() CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''
	::cCommandWhere  := ''

	::cCommandBuffer += "ROLLBACK" 		

	::Exec()

RETURN

*------------------------------------------------------------------------------------------*
METHOD Update(cTable,cWhere) CLASS SQL
*------------------------------------------------------------------------------------------*

	::cCommandBuffer := ''

	::cCommandWhere := cWhere

	::cCommandBuffer += "UPDATE " +  cTable + " SET " 		

RETURN

*--------------------------------------------------------------------------------------*
METHOD Exec(cCommand) CLASS SQL
*--------------------------------------------------------------------------------------*
LOCAL cRDD

	cRDD := RDDSETDEFAULT()

	RDDSETDEFAULT("SQLMIX")

	IF ValType(cCommand) = 'U' 

		IF Right( ::cCommandBuffer , 1 ) == ','

			::cCommandBuffer := LEFT( ::cCommandBuffer , LEN(::cCommandBuffer) - 1 )

		ENDIF

		IF .NOT. Empty(::cCommandWhere) 

			::cCommandBuffer += 'WHERE ' + ::cCommandWhere

		ENDIF

		::lError := .NOT. RDDINFO( RDDI_EXECUTE, ::cCommandBuffer , , ::nConnHandle )

		HB_MEMOWRIT( 'trace.log' , ::cCommandBuffer , .f. )

	ELSE

		HB_MEMOWRIT( 'trace.log' , cCommand , .f. )

		::lError := .NOT. RDDINFO( RDDI_EXECUTE, cCommand, , ::nConnHandle )

	ENDIF

	IF ValType(::lError) <> 'L'
		::lError := .T.
	ENDIF

	IF ::lError
		::cErrorDesc := rddinfo(RDDI_ERROR,,,::nConnHandle )
	else
		::cErrorDesc := ''
	ENDIF

	::cCommandBuffer := ''

	RDDSETDEFAULT(cRDD)

RETURN
lib.sql.ch

Code: Select all

#define RDDI_CONNECT          1001
#define RDDI_DISCONNECT       1002
#define RDDI_EXECUTE          1003
#define RDDI_ERROR            1004
#define RDDI_ERRORNO          1005
#define RDDI_NEWID            1006
#define RDDI_AFFECTEDROWS     1007
#define RDDI_QUERY            1008
Attached to this message is the library with a full example.

All this thing must be considered experimental.

I hope it be useful for someone.

Attachments

HMG EasySql Library
hmg.easy.sql.zip (1774.69 KiB)
]]> <![CDATA[HMG Samples :: Re: 'HMG EasySQL' a Simple SQL HMG library :: Reply by serge_girard]]> 2024-11-05T11:59:29+00:00 2024-11-05T11:59:29+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71392#p71392 <![CDATA[HMG Samples :: Re: 'HMG EasySQL' a Simple SQL HMG library :: Reply by ASESORMIX]]> 2024-11-05T12:34:35+00:00 2024-11-05T12:34:35+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71393#p71393
Muchísimas Gracias.]]>
Muchísimas Gracias.]]> <![CDATA[HMG Samples :: Re: 'HMG EasySQL' a Simple SQL HMG library :: Reply by edk]]> 2024-11-05T21:25:32+00:00 2024-11-05T21:25:32+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71396#p71396 <![CDATA[HMG Samples :: Re: 'HMG EasySQL' a Simple SQL HMG library :: Reply by vagblad]]> 2024-11-06T09:29:50+00:00 2024-11-06T09:29:50+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71398#p71398 <![CDATA[HMG Samples :: Re: 'HMG EasySQL' a Simple SQL HMG library :: Reply by mol]]> 2024-11-06T16:42:39+00:00 2024-11-06T16:42:39+00:00 http://mail.hmgforum.com/viewtopic.php?f=9&t=7618&p=71399#p71399 <![CDATA[HMG Utilities :: Search Beautiful Womans in your town for night - Verified Women :: Author MigSoft]]> 2024-10-22T15:10:47+00:00 2024-10-22T15:10:47+00:00 http://mail.hmgforum.com/viewtopic.php?f=10&t=7616&p=71382#p71382 Search Beautiful Womans from your city for night]]> Search Beautiful Womans from your city for night]]>