Cool sample code

[alex;]

*Monty Hall problem with optimize
*FOXPRO code
*Monty_Hall_problem test
*autor alex; alexeyzapolskiy at gmail.com
*24.06.2024

CLEAR ALL
LOCAL lni, lnw, lnv, lnTrue, lnTryings, lnQty
*lni - переменная цикла
*lnw - номер двери, за которой приз
*lnv - мой выбор
*lnTrue - количество угадываний
*lnTryings - количество попыток
*lnQty - количество дверей

lnQty = 3
LOCAL ARRAY arr1(lnQty)
lnTrue = 0
lnTryings = 1000000
FOR lni = 1 TO lnTryings
    arr1=0 && очищаем массив
    lnw = FLOOR(RAND()*lnQty)+1
    arr1[lnw] = 1
    lnv = FLOOR(RAND()*lnQty)+1
    IF arr1[lnv] = 0
        lnTrue = lnTrue + 1
    ENDIF
ENDFOR
?100*lnTrue/lnTryings

[alex;]

//Harbour code
PROCEDURE Main
LOCAL func := {|x, y| x - y}, func2
func2 := { | k, f | Eval(f, 2, 3) * k }
?Eval(func2, 5, func)

воскресенье, 31 августа 2025 г. в 21:16:40 UTC+3, alex;:

[alex;]

*FOXPRO code
FUNCTION Hex8(tnNum)
    IF m.tnNum = 0
        RETURN REPLICATE("0", 8)
    ENDIF
    LOCAL lcHex, lnDigit
    m.lcHex = ""
    DO WHILE ABS(m.tnNum) > 0
        m.lnDigit = BITAND(m.tnNum, 0x0F)
        m.lcHex = SUBSTR("0123456789ABCDEF", m.lnDigit + 1, 1) + m.lcHex
        m.tnNum = BITRShift(m.tnNum, 4)
    ENDDO
    RETURN PADL(m.lcHex, 8, "0")
ENDFUNC

воскресенье, 31 августа 2025 г. в 21:20:23 UTC+3, alex;:

[alex;]

Some cool code on foxpro is not intuitive at first glance, but it's still cool. For example https://www.foxite.com/faq/default.aspx?id=50

*!* *** Calling samples

*!*
*!* TEXT TO cSampleDataAsText TEXTMERGE noshow
*!* myCursor1,0
*!* myCursor2,0
*!* MyCursor3,10
*!* <<_samples+'data\Customer'>>,3
*!* <<_samples+'data\Employee'>>,5
*!* ENDTEXT

*!* sampleDataAsText(m.cSampleDataAsText)

*!* SampleDataAsText( ;
*!*   'myCursor1,0,'+;
*!*   'myCursor2,0,'+;
*!*   'myCursor3,10,'+;
*!*   _samples+'data\Customer,3,'+;
*!*   _samples+'data\Employee,5' )

*!* *** Calling is in pairs.
*!* **First one is an alias of open cursor/table
*!* **second specifies how many records to copy - 0 means all

* SampleDataAsText.prg
Lparameters tcInfo
LOCAL loCloseTemp, ix
loCloseTemp = CREATEOBJECT('CloseTemp')

LOCAL ARRAY laInfo[1]
Create Cursor crsSampler (procedureName m, procedureCode m)
For ix = 1 To ALINES(laInfo,m.tcInfo,1+4,',',CHR(13),CHR(10)) STEP 2
  GetProcedureCode(laInfo[m.ix],VAL(laInfo[m.ix+1]))
Endfor
DataCreationCodeToClip()
MESSAGEBOX('Data creation is copied to clipboard',0,'Sample Data',3000)

Procedure DataCreationCodeToClip
  Local Array aProcCode[1]
  Local lcTemp1,lcTemp2
  lcTemp1 = Sys(2015)+'.tmp'
  lcTemp2 = Sys(2015)+'.tmp'
  Select crsSampler
  Scan
    Strtofile(procedureName,m.lcTemp1,.T.)
    Strtofile(procedureCode,m.lcTemp2,.T.)
  Endscan
  _Cliptext = Filetostr(m.lcTemp1) + Filetostr(m.lcTemp2)
  Erase (m.lcTemp1)
  Erase (m.lcTemp2)
Endproc

Procedure GetProcedureCode(tcAlias,tnRecords)
  Local lcTemp, ix, lcData, lcRetVal
  lcTemp = Sys(2015)+'.tmp'
  If !Used(m.tcAlias)
    Select * From (m.tcAlias) Into Cursor crsSampling nofilter
    lcCursorName = Juststem(m.tcAlias)
  Else
    Select (m.tcAlias)
    lcCursorName = Alias()
  Endif
  Locate
  If Empty(m.tnRecords)
    Copy To (m.lcTemp) Type Delimited
  Else
    Copy To (m.lcTemp) Type Delimited Next m.tnRecords
  Endif
  lcData = Filetostr(m.lcTemp)
  Erase (m.lcTemp)

  Set Textmerge Delimiters To '%%','%%'
  Set Textmerge To (m.lcTemp) Noshow
  Set Textmerge On
\
\ Procedure CreateCursor_%%m.lcCursorName%%
\ LOCAL lcData, lcTemp
\ lcTemp = SYS(2015)+'.tmp'
\ TEXT TO m.lcData noshow
\ %%m.lcData%%
\ ENDTEXT
\
\ STRTOFILE(m.lcData,m.lcTemp)
\
\ create CURSOR %%m.lcCursorName%% ;
\ ( ;
  For ix=1 To Afields(aStruc)
\  %%IIF(m.ix > 1,',','')%%
\\%%aStruc[m.ix,1]%% %%aStruc[m.ix,2]%%(%%aStruc[m.ix,3]%%,%%aStruc[m.ix,4]%%)
\\ %%IIF(aStruc[m.ix,5],'',' NOT ')%% NULL
\\ %%IIF(aStruc[m.ix,6],'NOCPTRANS','')%% ;
  Endfor
\  )
\
\ APPEND FROM (m.lcTemp) TYPE delimited
\ ERASE (m.lcTemp)
\ endproc
  Set Textmerge To
  Set Textmerge Off
  Insert Into crsSampler Values ( Textmerge('CreateCursor_%%m.lcCursorName%%()%%CHR(13)+CHR(10)%%'), Filetostr(m.lcTemp) )
  Set Textmerge Delimiters
  Erase (m.lcTemp)
ENDPROC

** Class to close any cursors created after it was instantiated
** Author: Dragan Nedeljkovich
Define Class CloseTemp As Custom
  Dimension a1[1]
  nFiles=0
  Procedure Init
    This.nFiles=Aused(atemp)
    If This.nFiles > 0
      Acopy(atemp, This.a1)
    Else
      This.a1=""
    Endif
  endproc

  Procedure Destroy
    For i=1 To Aused(aNow)
      If Ascan(This.a1, aNow[i,1],-1,-1,1,2+4)=0
        Use In aNow[i,1]
      Endif
    Endfor
  endproc
Enddefine

воскресенье, 31 августа 2025 г. в 23:25:17 UTC+3, alex;: