Cool sample code

79 views
Skip to first unread message

alex;

unread,
Aug 31, 2025, 2:16:40 PMAug 31
to xbasians.org
*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;

unread,
Aug 31, 2025, 2:20:23 PMAug 31
to xbasians.org
//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;

unread,
Aug 31, 2025, 4:25:17 PMAug 31
to xbasians.org
*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;

unread,
Sep 4, 2025, 1:36:34 AMSep 4
to xbasians.org
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;:

alex;

unread,
Sep 21, 2025, 9:06:38 AMSep 21
to xbasians.org

*Foxpro code
* I prefer controls in the bottom-right and top-left corners of the grid,
* responsible for move and resize.

USE IN SELECT("customers")
USE  (HOME()+"\samples\data\customer.dbf") ALIAS customers

PUBLIC oMyForm as Form
oMyForm = CREATEOBJECT("frmTest")
oMyForm.Show()
oMyForm.Refresh
READ EVENTS

CLEAR ALL

DEFINE CLASS frmTest AS FORM
   *DoCreate = .T.
   ADD OBJECT oContainerWithGrid as ContainerWithGrid WITH ;
      Left = 10, Top = 10, Width = 300, Height = 200
       
   PROCEDURE Destroy
    DODEFAULT()
    CLEAR EVENTS
ENDDEFINE

DEFINE CLASS ContainerWithGrid AS CONTAINER
Width = 300
Height = 200
   *DOCREATE = .T.
   Name = 'ContainerWithGrid'
   Capture = .F.
   Resizable = .T.
   Movable = .T.
       
lIsResizing = .F.
lIsMoving   = .F.

   * Property to store the old mouse position
   ADD OBJECT OldPosition as Point

   ADD OBJECT oGrid as GRID

   ADD OBJECT oChkMove   AS MoveHandle WITH Left=0, Top=0
   ADD OBJECT oChkResize AS ResizeHandle

   PROCEDURE Init()
      WITH this.oGrid
         *.Parent = THISFORM.ContainerWithGrid
         *.Dock = 0
         .Visible = .T.
         .Height = .parent.Height - 20
         .Width = .parent.Width - 20
         .Left = 10
         .Top = 10
         .RecordSourceType = 1
         .RecordSource = 'customers' && Table 'customers' must exist
         .AllowAddNew = .F.
         *.AllowDelete = .F.
         .ColumnCount = 2
         .refresh
      ENDWITH
       
      * Place resize handle immediately in the corner
      THIS.oChkResize.Left = THIS.Width - THIS.oChkResize.Width
      THIS.oChkResize.Top  = THIS.Height - THIS.oChkResize.Height
   ENDPROC
ENDDEFINE

* === Base class for handles ===
DEFINE CLASS Handle AS checkbox
   Caption = ""
   Style   = 1
   Height  = 20
   Width   = 20
   PicturePosition = 14

   PROCEDURE MouseDown(nButton, nShift, nXCoord, nYCoord)
      THIS.Parent.Capture = .T.
      THIS.Parent.OldPosition.X = nXCoord
      THIS.Parent.OldPosition.Y = nYCoord
   ENDPROC

   PROCEDURE MouseUp(nButton, nShift, nXCoord, nYCoord)
      THIS.Parent.Capture = .F.
      THIS.Parent.OldPosition.X = 0
      THIS.Parent.OldPosition.Y = 0
      THIS.Value = 0
      THIS.Refresh
      NODEFA
   ENDPROC

   PROCEDURE Click
      NODEFA   && fully disable the default checkbox toggle
   ENDPROC
ENDDEFINE


* === Handle for moving ===
DEFINE CLASS MoveHandle AS Handle
   Picture = HOME()+"\graphics\icons\dragdrop\drag1pg.ico"

   PROCEDURE MouseMove(nButton, nShift, nXCoord, nYCoord)
      IF THIS.Parent.Capture
         LOCAL nDX, nDY
         nDX = nXCoord - THIS.Parent.OldPosition.X
         nDY = nYCoord - THIS.Parent.OldPosition.Y
         THIS.Parent.Left = THIS.Parent.Left + nDX
         THIS.Parent.Top  = THIS.Parent.Top  + nDY
         THIS.Parent.OldPosition.X = nXCoord
         THIS.Parent.OldPosition.Y = nYCoord
      ENDIF
   ENDPROC
ENDDEFINE


* === Handle for resizing ===
DEFINE CLASS ResizeHandle AS Handle
   Picture = HOME()+"\graphics\Cursors\NW_05.CUR"

   PROCEDURE MouseMove(nButton, nShift, nXCoord, nYCoord)
      IF THIS.Parent.Capture
         LOCAL nDX, nDY
         nDX = nXCoord - THIS.Parent.OldPosition.X
         nDY = nYCoord - THIS.Parent.OldPosition.Y

         THIS.Parent.Width  = MAX(50, THIS.Parent.Width  + nDX)
         THIS.Parent.Height = MAX(40, THIS.Parent.Height + nDY)

         * Adjust the grid size
         THIS.Parent.oGrid.Width  = THIS.Parent.Width - 20
         THIS.Parent.oGrid.Height = THIS.Parent.Height - 20

         * Update the resize handle position itself
         THIS.Left = THIS.Parent.Width - THIS.Width
         THIS.Top  = THIS.Parent.Height - THIS.Height

         THIS.Parent.OldPosition.X = nXCoord
         THIS.Parent.OldPosition.Y = nYCoord
         
         *this.refresh
      ENDIF
   ENDPROC
ENDDEFINE

DEFINE CLASS Point AS Custom
    X = 0
    Y = 0
ENDDEFINE
четверг, 4 сентября 2025 г. в 08:36:34 UTC+3, alex;:

alex;

unread,
Sep 25, 2025, 2:08:56 PMSep 25
to xbasians.org
*Foxpro code
CLEAR
Application.Visible = .F.

SET SAFETY OFF
ON KEY LABEL ALT+Q CLEAR EVENTS

LOCAL lni, lcTempFile, frmWEditMain as FrmMain
lcTempFile = 'c:\temp\chars1.txt'

*   _SCREEN.Visible = .T.

*!* _SCREEN.FontName = "Arial"
*!* _SCREEN.FontSize = 12
*!* _SCREEN.FontCharSet = 0

frmWEditMain = CREATEOBJECT("FrmMain")
frmWEditMain .Show()
*!* READ EVENTS

*!*    DEFINE WINDOW wEditMain FROM 1,40 TO 60,170 MDI SYSTEM CLOSE FLOAT ZOOM NOMINIMIZE GROW IN DESKTOP NAME frmWEditMain
*!*    *frmWEditMain.ShowWindow = 2
*!*    *frmWEditMain.WindowType = 1
*!*    ACTIVATE WINDOW wEditMain
*!*    SHOW WINDOW wEditMain
*!*    frmWEditMain.Closable = .T.
*!*    frmWEditMain.WindowState = 2
*!*    frmWEditMain.Visible = .T.
*!*    frmWEditMain.Show()


SET TEXTMERGE ON
SET TEXTMERGE TO (lcTempFile)

FOR m.lni = 192 TO 191 + 32
\<<'CODE: #' + TRANSFORM(m.lni) + ' - ' + CHR(m.lni) + ', CODE: #' + TRANSFORM(m.lni+32) + ' - ' + CHR(m.lni+32)>>
ENDFOR

SET TEXTMERGE TO
SET TEXTMERGE OFF

COPY FILE c:\temp\chars.txt TO c:\temp\chars2.txt
COPY FILE c:\temp\chars.txt TO c:\temp\chars3.txt

*CLOSE ALL

IF .T. AND FILE(lcTempFile)

   DEFINE WINDOW wEdit1 FROM 1,1 TO 50,100 FONT "FoxFont", 12 GROW MINIMIZE FLOAT IN FrmMain NAME frmEdit1
   *ACTIVATE WINDOW wEdit1
   *frmEdit.FontCharSet = 0
   frmEdit1.FontSize = 15
   MODIFY FILE (lcTempFile) WINDOW wEdit1 IN WINDOW FrmMain SAVE NOWAIT

   DEFINE WINDOW wEdit2 FROM 6,16 TO 56,116 FONT "Arial", 12 GROW MINIMIZE FLOAT IN WINDOW FrmMain NAME frmEdit2
   *ACTIVATE WINDOW wEdit2
   frmEdit2.FontCharSet = 0
   frmEdit2.FontSize = 15
   MODIFY FILE (CHRTRAN(lcTempFile,"1","2")) WINDOW wEdit2 IN WINDOW FrmMain NOEDIT SAVE NOWAIT
   
   DEFINE WINDOW wEdit3 FROM 11,31 TO 60,131 FONT "Arial", 12 GROW MINIMIZE FLOAT IN WINDOW FrmMain NAME frmEdit3
   *ACTIVATE WINDOW wEdit3
   frmEdit3.FontCharSet = 204
   frmEdit3.FontSize = 15
   MODIFY FILE (CHRTRAN(lcTempFile,"1","3")) WINDOW wEdit3 IN WINDOW FrmMain NOEDIT SAVE NOWAIT
   
ENDIF

READ EVENTS
*_SCREEN.FontCharSet = 204
Application.Visible = .T.


DEFINE CLASS FrmMain as Form
Closable = .T.
ShowWindow = 2
* WindowState = 2
WindowType = 1
Height = 920
Width = 1000

PROCEDURE Destroy
CLEAR EVENTS
ENDDEFINE

воскресенье, 21 сентября 2025 г. в 16:06:38 UTC+3, alex;:

alex;

unread,
Sep 26, 2025, 7:30:27 PMSep 26
to xbasians.org
Full version of the previous code with all charsets from learn.microsoft.com here forum.foxclub.ru

WBR, alex;
четверг, 25 сентября 2025 г. в 21:08:56 UTC+3, alex;:

alex;

unread,
Oct 4, 2025, 11:34:25 AMOct 4
to xbasians.org
*Foxpro code
#DEFINE N_CP 1251
#DEFINE C_CP ALLTRIM(TRANS(N_CP))
#DEFINE N_CS 204

#DEFINE C_WINDOW_SCREEN .F.
#DEFINE C_FONTNAME "Arial Unicode MS"


ON KEY LABEL ALT+Q CLEAR EVENTS

CLOSE DATABASES ALL

*SET COLLATE TO "HUNGARY"
LOCAL Frm_Name
#IF C_WINDOW_SCREEN

#DEFINE C_WINDOW SCREEN

ACTIVATE SCREEN

Frm_Name = "_SCREEN"
#ELSE
#DEFINE C_WINDOW "wBrowse" + ALLTRIM(TRANS(N_CP)) + "_" + ALLTRIM(TRANS(N_CS))
Frm_Name = "_" + C_WINDOW
cmd = "PRIVATE " + Frm_Name

    SET COLOR OF SCHEME 20 TO RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125), RGB(200,200,200, 31, 73, 125)
DEFINE WINDOW (C_WINDOW) FROM 10,10 TO 55,200 FONT C_FONTNAME, 10 STYLE "B" SYSTEM CLOSE GROW MINIMIZE FLOAT ZOOM IN DESKTOP NAME (Frm_Name) COLOR SCHEME 20 ;
TITLE C_WINDOW + " CODEPAGE "+ TRANSFORM(N_CP) + " FontCharSet "+ TRANSFORM(N_CP)

ACTIVATE WINDOW (C_WINDOW)
#ENDIF

CLEAR

*?C_WINDOW
?Frm_Name

CREATE TABLE chars CODEPAGE = N_CP (dec N(3), hex C(2), Glyph C(1), c_unicode C(4), ;
                    c_n_uni C(6), uni_ascw N(10), c_utf8 C(4), ;
                    len_utf8 N(1), c_hex_utf8 C(10), dec_utf8 N(10))

&Frm_Name..FontName = C_FONTNAME

LOCAL lni, lc_uni, lc_n_uni, lc_utf8, lc_hex_utf8
FOR m.lni = 1 TO 255
lc_uni = STRCONV(CHR(m.lni), 5, N_CP, 1)
lc_n_uni = STRCONV(lc_uni,15)

lc_utf8 = STRCONV(CHR(m.lni), 9, N_CP, 1)
lc_hex_utf8 = STRCONV(lc_utf8, 15)         && UTF-8 в hex

#IF .F.
&Frm_Name..FontCharSet = 204
? ;
m.lni, ;
STRCONV(CHR(m.lni),15), ;
CHR(m.lni), ;
lc_uni, ;
"U+" + RIGHT(lc_n_uni,2) + LEFT(lc_n_uni,2), ;
EVAL("0x" + RIGHT(lc_n_uni,2) + LEFT(lc_n_uni,2)), ;
lc_utf8, ;
LEN(lc_utf8)

&Frm_Name..FontCharSet = N_CS
?CHR(m.lni)

IF (m.lni+1)%16 = 0
WAIT
ENDIF
#ENDIF

    INSERT INTO chars VALUES( ;
        m.lni, ;                              && Decimal код
        STRCONV(CHR(m.lni),15), ;             && Hex код
        CHR(m.lni), ;                         && Символ
        lc_uni, ;                            && Unicode представление
        "U+" + RIGHT(lc_n_uni,2) + LEFT(lc_n_uni,2), ;  && Unicode hex код
        EVAL("0x" + RIGHT(lc_n_uni,2) + LEFT(lc_n_uni,2)), ;                       && Decimal Unicode
        lc_utf8, ;                           && UTF-8 представление
        LEN(lc_utf8), ;                      && Длина UTF-8
        lc_hex_utf8, ;                        && Hex UTF-8
        EVALUATE("0x"+ RIGHT(lc_hex_utf8,2) + LEFT(lc_hex_utf8,2)) ;
    )

ENDFOR

*&Frm_Name..FontCharSet = 204

?STRCONV(CHR(192), 5, N_CP, 1)
?STRCONV(CHR(192), 5, 1049)

WAIT

CLEAR
lcTmp = IIF(C_WINDOW_SCREEN,"IN SCREEN", "IN WINDOW " + C_WINDOW)
? "Таюлица символов:"

SELECT chars

DO CASE
CASE N_CP = 1250
INDEX ON Glyph TAG s_alpha COLLATE "HUNGARY"
CASE N_CP = 1251
INDEX ON Glyph TAG s_alpha COLLATE "RUSSIAN"
OTHERWISE
INDEX ON Glyph TAG s_alpha
ENDCASE

BROWSE TITLE "Символы кодовой страницы " + TRANSFORM(N_CP) + " (160-255)" &lcTmp FONT C_FONTNAME, 10 STYLE "B" NOWAIT NAME qwe
qwe.FontCharSet = N_CS

*_SCREEN.FontCharSet = 204

READ EVENTS

WBR, alex;
суббота, 27 сентября 2025 г. в 02:30:27 UTC+3, alex;:
Reply all
Reply to author
Forward
0 new messages