Some of my codes

remi_meier · Post by **remi_meier** » Sat Sep 24, 2005 8:45 pm

Cause of the delay of the CodeArchiv, I'll post some of my source codes
here, too.
Sorry that I don't have a better 'subject', but I also didn't want to post
them all in seperate threads.

Free for use, credits are always nice

Vector-Class
For calculating with vectors.

Code: Select all

; Example below! Function description can be found in the interface declaration
Structure cOVECTORVT
	; Functions
	fSetXYZ.l
	fSetV.l
	fGetX.l
	fGetY.l
	fGetZ.l
	fGetLength.l
	fGetLengthSqr.l
	fSetX.l
	fSetY.l
	fSetZ.l
	fAddV.l
	fAddXYZ.l
	fSubV.l
	fSubXYZ.l
	fGetDotPV.l
	fCrossPV.l
	fCpy2OV.l
	fMul.l
	fDiv.l
	fNormalize.l
	fGetDataPtr.l
	fGetDataFromMem.l
	fRotateAroundX.l
	fRotateAroundY.l
	fRotateAroundZ.l
	fRotateAroundV.l
EndStructure

Structure cOVECTOR
	VTable.l
	
	; Data
	x.f
	y.f
	z.f
EndStructure

Interface iOVECTOR
	SetXYZ(x.f, y.f, z.f) ;Set x, y, z parts of vector seperately
	SetV(*v.cOVECTOR) ;Set x,y,z like the vector as parameter
	GetX.f() ;Get x part
	GetY.f() ;Get y part
	GetZ.f() ;Get z part
	GetLength.f() ;Get length of vector (norm)
	GetLengthSqr.f() ;Get the length in square
	SetX(x.f) ;Set x part
	SetY(y.f) ;Set y part
	SetZ(z.f) ;Set z part
	AddV(*v.cOVECTOR) ;Add a vector
	AddXYZ(x.f, y.f, z.f) ;Add a vector
	SubV(*v.cOVECTOR) ;Sub a vector
	SubXYZ(x.f, y.f, z.f) ;Sub a vector
	GetDotPV.f(*v.cOVECTOR) ;Get dotproduct (scalar) with *v
	CrossPV(*v.cOVECTOR) ;Get crossproduct (vector) with *v
	Cpy2OV.l() ;Creates a copy of the vector (allocates a new object!)
	Mul(Factor.f) ;Multiply with a factor (stretch)
	Div(Divisor.f) ;Divide by a divisor (compress)
	Normalize() ;Recalculates vector to length of 1.0
	GetDataPtr.l() ;Gets pointer to XYZ in memory (3 floats in memory)
	GetDataFromMem(*mem) ;Sets XYZ like in *mem
	RotateAroundX(a.f) ;Rotates around x axis
	RotateAroundY(a.f) ;Rotates around y axis
	RotateAroundZ(a.f) ;Rotates around z axis
	RotateAroundV(*v.cOVECTOR, a.f) ;Rotates around a vector
EndInterface



Procedure vect_SetXYZ(*this.cOVECTOR, x.f, y.f, z.f)
	*this\x = x
	*this\y = y
	*this\z = z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_SetV(*this.cOVECTOR, *v.cOVECTOR)
	If *v
		*this\x = *v\x
		*this\y = *v\y
		*this\z = *v\z
	EndIf
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure.f vect_GetX(*this.cOVECTOR)
	ProcedureReturn *this\x
EndProcedure

Procedure.f vect_GetY(*this.cOVECTOR)
	ProcedureReturn *this\y
EndProcedure

Procedure.f vect_GetZ(*this.cOVECTOR)
	ProcedureReturn *this\z
EndProcedure

Procedure.f vect_GetLength(*this.cOVECTOR)
	ProcedureReturn Sqr(*this\x * *this\x + *this\y * *this\y + *this\z * *this\z)
EndProcedure

Procedure.f vect_GetLengthSqr(*this.cOVECTOR)
	ProcedureReturn *this\x * *this\x + *this\y * *this\y + *this\z * *this\z
EndProcedure

Procedure vect_SetX(*this.cOVECTOR, x.f)
	*this\x = x
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_SetY(*this.cOVECTOR, y.f)
	*this\y = y
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_SetZ(*this.cOVECTOR, z.f)
	*this\z = z
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_AddV(*this.cOVECTOR, *v.cOVECTOR)
	If *v
		*this\x + *v\x
		*this\y + *v\y
		*this\z + *v\z
	EndIf
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_AddXYZ(*this.cOVECTOR, x.f, y.f, z.f)
	*this\x + x
	*this\y + y
	*this\z + z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_SubV(*this.cOVECTOR, *v.cOVECTOR)
	If *v
		*this\x - *v\x
		*this\y - *v\y
		*this\z - *v\z
	EndIf
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_SubXYZ(*this.cOVECTOR, x.f, y.f, z.f)
	*this\x - x
	*this\y - y
	*this\z - z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure.f vect_GetDotPV(*this.cOVECTOR, *v.cOVECTOR)
	If *v
		ProcedureReturn *this\x * *v\x + *this\y * *v\y + *this\z * *v\z
	EndIf
	
	ProcedureReturn 0
EndProcedure

Procedure vect_CrossPV(*this.cOVECTOR, *v.cOVECTOR)
	Protected vx.f, vy.f, tx.f, ty.f, tz.f
	
	If *v
		tx = *this\x
		ty = *this\y
		tz = *this\z
		*this\x = ty * *v\z - tz * *v\y
		*this\y = tz * *v\x - tx * *v\z
		*this\z = tx * *v\y - ty * *v\x
	EndIf
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Declare new_ovector()
Procedure vect_Cpy2OV(*this.cOVECTOR)
	Protected *v.iOVECTOR
	
	*v.iOVECTOR = new_ovector()
	*v\SetV(*this)
	
	ProcedureReturn *v
EndProcedure

Procedure vect_Mul(*this.cOVECTOR, Factor.f)
	*this\x * Factor
	*this\y * Factor
	*this\z * Factor
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_Div(*this.cOVECTOR, Divisor.f)
	Protected f.f
	
	f = 1.0 / Divisor
	*this\x * f
	*this\y * f
	*this\z * f
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_Normalize(*this.cOVECTOR)
	Protected Len.f
	
	Len = 1.0 / vect_GetLength(*this)
	*this\x * Len
	*this\y * Len
	*this\z * Len
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure.l vect_GetDataPtr(*this.cOVECTOR)
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_GetDataFromMem(*this.cOVECTOR, *mem)
	CopyMemory(*mem, *this + OffsetOf(cOVECTOR\x), 3 * 4)
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_RotateAroundX(*this.cOVECTOR, a.f)
	Protected x.f, y.f, z.f
	
	x = *this\x
	y = *this\y
	z = *this\z
	; M * *this
	*this\x = x
	*this\y = Cos(a) * y - Sin(a) * z
	*this\z = Sin(a) * y + Cos(a) * z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_RotateAroundY(*this.cOVECTOR, a.f)
	Protected x.f, y.f, z.f
	
	x = *this\x
	y = *this\y
	z = *this\z
	; M * *this
	*this\x = Cos(a) * x + Sin(a) * z
	*this\y = y
	*this\z = -Sin(a) * x + Cos(a) * z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_RotateAroundZ(*this.cOVECTOR, a.f)
	Protected x.f, y.f, z.f
	
	x = *this\x
	y = *this\y
	z = *this\z
	; M * *this
	*this\x = Cos(a) * x - Sin(a) * y
	*this\y = Sin(a) * x + Cos(a) * y
	*this\z = z
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure

Procedure vect_RotateAroundV(*this.cOVECTOR, *v.cOVECTOR, a.f) ; *v has to be normalized
	Protected x.f, y.f, z.f, cosa.f, sina.f, ecosa.f
	
	cosa = Cos(a)
	sina = Sin(a)
	ecosa = 1.0 - cosa
	
	x = *this\x
	y = *this\y
	z = *this\z
	; M * *this
	*this\x = x * (cosa + *v\x * *v\x * ecosa) + y * (*v\x * *v\y * ecosa - *v\z * sina) + z * (*v\x * *v\z * ecosa + *v\y * sina)
	*this\y = x * (*v\y * *v\x * ecosa + *v\z * sina) + y * (cosa + *v\y * *v\y * ecosa) + z * (*v\y * *v\z * ecosa - *v\x * sina)
	*this\z = x * (*v\z * *v\x * ecosa - *v\y * sina) + y * (*v\z * *v\y * ecosa + *v\x * sina) + z * (cosa + *v\z * *v\z * ecosa)
	
	
	ProcedureReturn *this + OffsetOf(cOVECTOR\x)
EndProcedure




Procedure.l new_ovector()
	Protected *v.cOVECTOR
	Static *VTable.cOVECTORVT
	
	If *VTable = 0
		*VTable = AllocateMemory(SizeOf(cOVECTORVT))
		*VTable\fSetXYZ				= @vect_SetXYZ()
		*VTable\fSetV					= @vect_SetV()
		*VTable\fGetX					= @vect_GetX()
		*VTable\fGetY					= @vect_GetY()
		*VTable\fGetZ					= @vect_GetZ()
		*VTable\fGetLength		= @vect_GetLength()
		*VTable\fGetLengthSqr	= @vect_GetLengthSqr()
		*VTable\fSetX					= @vect_SetX()
		*VTable\fSetY					= @vect_SetY()
		*VTable\fSetZ					= @vect_SetZ()
		*VTable\fAddV					= @vect_AddV()
		*VTable\fAddXYZ				= @vect_AddXYZ()
		*VTable\fSubV					= @vect_SubV()
		*VTable\fSubXYZ				= @vect_SubXYZ()
		*VTable\fGetDotPV			= @vect_GetDotPV()
		*VTable\fCrossPV			= @vect_CrossPV()
		*VTable\fCpy2OV				= @vect_Cpy2OV()
		*VTable\fMul					= @vect_Mul()
		*VTable\fDiv					= @vect_Div()
		*VTable\fNormalize		= @vect_Normalize()
		*VTable\fGetDataPtr		= @vect_GetDataPtr()
		*VTable\fGetDataFromMem = @vect_GetDataFromMem()
		*VTable\fRotateAroundX	= @vect_RotateAroundX()
		*VTable\fRotateAroundY	= @vect_RotateAroundY()
		*VTable\fRotateAroundZ	= @vect_RotateAroundZ()
		*VTable\fRotateAroundV	= @vect_RotateAroundV()
	EndIf
	
	*v = AllocateMemory(SizeOf(cOVECTOR))
	*v\VTABLE = *VTable
		
	ProcedureReturn *v
EndProcedure



; DefType.iOVECTOR a, b
; 
; a = new_ovector()
; b = new_ovector()
; 
; a\SetXYZ(1, 2, 0)
; b\SetXYZ(2, 3, 0)
; a\SubV(b)
; 
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; a\Normalize()
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; Debug a\GetLength()
; Debug a\GetLengthSqr()

; NewList vec.iOVECTOR()
; AddElement(vec())
; vec() = new_ovector()
; vec()\SetXYZ(1, 2, 0)
; 
; AddElement(vec())
; vec() = new_ovector()
; vec()\SetXYZ(3, 21, 0)
; 
; Debug vec()\GetX()




; DefType.iOVECTOR a, b
; 
; a = new_ovector()
; b = new_ovector()
; 
; a\SetXYZ(0, 10, 0)
; b\SetXYZ(1, 0, 0) ; X-Achse ^^
; b\Normalize() ; wäre nicht nötig hier
; 
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; Debug "RotateX"
; a\RotateAroundX(3.1415926 / 2.0)
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; Debug "RotateY"
; a\RotateAroundY(3.1415926 / 2.0)
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; Debug "RotateZ"
; a\RotateAroundZ(3.1415926 / 2.0)
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()
; 
; Debug "RotateV = RotateX"
; a\RotateAroundV(b, 3.1415926 / 2.0)
; Debug a\GetX()
; Debug a\GetY()
; Debug a\GetZ()

Simple Inheritance for Interfaces
How does one interface inherit functions and datas from another.

Code: Select all

;- BASE class
; this class will be inherited by iOBJ with all its methods and data fields
Interface iBASE
	SetS(s.s)
	GetS.s()
	SetL(l.l)
	GetL.l()
	SetF(f.f)
	GetF.f()
EndInterface

Structure cBASEVT
	SetS.l
	GetS.l
	SetL.l
	GetL.l
	SetF.l
	GetF.l
EndStructure

; only iBASE can have a VT pointer because it has to be the first LONG
; in the object stucture!
Structure cBASE
	*VTable.cBASEVT
	
	;Data
	s.s
	l.l
	f.f
EndStructure



;- OBJ class
; this class will inherit iBASE and so will get new functions and data fields
; the structure/interface of iBASE will be inserted just at the start of the
; iOBJ structure/interface -> VT pointer will be from iBASE and the first
; field in the structure
Interface iOBJ Extends iBASE
	SetW(w.w)
	GetW.w()
	SetB(b.b)
	GetB.b()
EndInterface

Structure cOBJVT Extends cBASEVT
	SetW.l
	GetW.l
	SetB.l
	GetB.l
EndStructure

Structure cOBJ Extends cBASE
	w.w
	b.b
EndStructure



;- BASE functions
Procedure base_SetS(*this.cBASE, s.s)
	*this\s = s
EndProcedure
Procedure.s base_GetS(*this.cBASE)
	ProcedureReturn *this\s
EndProcedure
Procedure base_SetL(*this.cBASE, l.l)
	*this\l = l
EndProcedure
Procedure.l base_GetL(*this.cBASE)
	ProcedureReturn *this\l
EndProcedure
Procedure base_SetF(*this.cBASE, f.f)
	*this\f = f
EndProcedure
Procedure.f base_GetF(*this.cBASE)
	ProcedureReturn *this\f
EndProcedure

;- BASE constructor
Procedure.l new_base()
	Protected *p.cBASE
	Static *VTable.cBASEVT
	
	If *VTable = 0
		; just allocate for its own functions!
		*VTable = AllocateMemory(SizeOf(cBASEVT))
		*VTable\SetS = @base_SetS()
		*VTable\GetS = @base_GetS()
		*VTable\SetL = @base_SetL()
		*VTable\GetL = @base_GetL()
		*VTable\SetF = @base_SetF()
		*VTable\GetF = @base_GetF()
	EndIf
	
	*p = AllocateMemory(SizeOf(cBASE))
	*p\VTable = *VTable
	
	ProcedureReturn *p
EndProcedure


;- OBJ functions
Procedure obj_SetW(*this.cOBJ, w.w)
	*this\w = w
EndProcedure
Procedure.w obj_GetW(*this.cOBJ)
	ProcedureReturn *this\w
EndProcedure
Procedure obj_SetB(*this.cOBJ, b.b)
	*this\b = b
EndProcedure
Procedure.b obj_GetB(*this.cOBJ)
	ProcedureReturn *this\b
EndProcedure

;- OBJ constructor
Procedure.l new_obj()
	Protected *p.cOBJ, *vt.cOBJVT
	
	; grow up the VT to make place for obj_-functions!
	*p 				= ReAllocateMemory(new_base(), SizeOf(cOBJ))
	*p\VTable = ReAllocateMemory(*p\VTable, SizeOf(cOBJVT))
	
	If *p\VTable <> 0
		*vt = *p\VTable
		*vt\SetW = @obj_SetW()
		*vt\GetW = @obj_GetW()
		*vt\SetB = @obj_SetB()
		*vt\GetB = @obj_GetB()
	EndIf
	
	ProcedureReturn *p
EndProcedure



Debug "### The BASE-Class ###"
; will be only of type iBASE!
DefType.iBASE b
b = new_base()

b\SetS("hallo")
b\SetL(20)
b\SetF(21.023)

Debug b\GetS()
Debug b\GetL()
Debug b\GetF()


Debug "### Now the object ###"
; could also be accessed through a iBASE interface pointer
; iOBJ is MORE than iBASE but CONTAINS iBASE
DefType.iOBJ o
o = new_obj()

o\SetS("obj")
o\SetL(666)
o\SetF(616)

o\SetB(11)
o\SetW(12)

CallDebugger
Debug o\GetS()
Debug o\GetL()
Debug o\GetF()

Debug o\GetB()
Debug o\GetW()

Simple Wrapper for TreeGadget-Macros by MSDN
Some extended functions for treeview-gadget.

Code: Select all

; See MSDN for more information about each function
Interface cTreeView
	InsertItem(lpis.l)
	DeleteItem(hItem.l)
	DeleteAllItems()
	Expand(hItem.l, Flag.l)
	GetItemRect(hItem.l, prc.l, fItemRect.l)
	GetCount()
	GetIndent()
	SetIndent(Indent.l)
	GetImageList(iImage.l)
	SetImageList(himl.l, iImage.l)
	GetNextItem(hItem.l, Flag.l)
	GetChild(hItem.l)
	GetNextSibling(hItem.l)
	GetPrevSibling(hItem.l)
	GetParent(hItem)
	GetFirstVisible()
	GetNextVisible(hItem.l)
	GetPrevVisible(hItem.l)
	GetSelection()
	GetDropHilight()
	GetRoot()
	GetLastVisible()
	Select(hItem.l, Flag.l)
	SelectItem(hItem.l)
	SelectDropTarget(hItem.l)
	SelectSetFirstVisible(hItem.l)
	GetItem(pitem.l)
	SetItem(pitem.l)
	EditLabel(hItem.l)
	GetEditControl()
	GetVisibleCount()
	HitTest(lpht.l)
	CreateDragImage(hItem.l)
	SortChildren(hItem.l, fRecurse.l)
	EnsureVisible(hItem.l)
	SortChildrenCB(psort.l, fRecurse.l)
	EndEditLabelNow(fCancel.l)
	GetISearchString(lpsz.l)
	SetToolTips(hwndTT.l)
	GetToolTips()
	SetInsertMark(hItem.l, fAfter.l)
	SetUnicodeFormat(fUnicode.l)
	SetItemHeight(iHeight.l)
	GetItemHeight()
	SetBkColor(clr.l)
	SetTextColor(clr.l)
	GetBkColor()
	GetTextColor()
	SetScrollTime(uTime.l)
	GetScrollTime()
	SetInsertMarkColor(clr.l)
	GetInsertMarkColor()
	SetItemState(hItem.l, Datan.l, _mask.l)
	SetCheckState(hItem.l, fCheck.l)
	GetItemState(hItem.l, mask.l)
	GetCheckState(hItem.l)
	SetLineColor(clr.l)
	GetLineColor()
	MapHTREEITEMToAccID(HTREEITEM.l)
	MapAccIDToHTREEITEM(ID.l)
EndInterface

Structure cTreeViewOBJ
	VTable.l
	f.l[60] ; [SizeOf(cTreeView) / 4]
	
	hGadget.l
EndStructure


#TVM_SETTOOLTIPS = $1100 + 24
#TVM_GETTOOLTIPS = $1100 + 25
#TVM_SETINSERTMARK = $1100 + 26
#TVM_SETUNICODEFORMAT = $2000 + 5
#TVM_GETUNICODEFORMAT = $2000 + 5
#TVM_SETITEMHEIGHT = $1100 + 27
#TVM_GETITEMHEIGHT = $1100 + 28
#TVM_SETBKCOLOR = $1100 + 29
#TVM_SETTEXTCOLOR = $1100 + 30
#TVM_GETBKCOLOR = $1100 + 31
#TVM_GETTEXTCOLOR = $1100 + 32
#TVM_SETSCROLLTIME = $1100 + 33
#TVM_GETSCROLLTIME = $1100 + 34
#TVM_SETINSERTMARKCOLOR = $1100 + 37
#TVM_GETINSERTMARKCOLOR = $1100 + 38
#TVM_GETITEMSTATE = $1100 + 39
#TVM_SETLINECOLOR = $1100 + 40
#TVM_GETLINECOLOR = $1100 + 40
#TVM_MAPHTREEITEMTOACCID = $1100 + 43
#TVM_MAPACCIDTOHTREEITEM = $1100 + 42
#TVGN_LASTVISIBLE = $A

Structure TVITEM
  mask.l
  hItem.l
  state.l
  stateMask.l
  pszText.l
  cchTextMax.l
  iImage.l
  iSelectedImage.l
  cChildren.l
  LPARAM.l
EndStructure


Procedure TreeView_InsertItem(*Gadget.cTreeViewOBJ, lpis.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_INSERTITEM, 0, lpis)
EndProcedure
Procedure TreeView_DeleteItem(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_DELETEITEM, 0, hItem)
EndProcedure
Procedure TreeView_DeleteAllItems(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_DELETEITEM, 0, #TVI_ROOT)
EndProcedure
Procedure TreeView_Expand(*Gadget.cTreeViewOBJ, hItem.l, Flag.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_EXPAND, Flag, hItem)
EndProcedure
Procedure TreeView_GetItemRect(*Gadget.cTreeViewOBJ, hItem.l, prc.l, fItemRect.l)
  ;-?
  PokeL(prc, hItem)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETITEMRECT, fItemRect, prc)
EndProcedure
Procedure TreeView_GetCount(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETCOUNT, 0, 0)
EndProcedure
Procedure TreeView_GetIndent(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETINDENT, 0, 0)
EndProcedure
Procedure TreeView_SetIndent(*Gadget.cTreeViewOBJ, Indent.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETINDENT, Indent, 0)
EndProcedure
Procedure TreeView_GetImageList(*Gadget.cTreeViewOBJ, iImage.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETIMAGELIST, iImage, 0)
EndProcedure
Procedure TreeView_SetImageList(*Gadget.cTreeViewOBJ, himl.l, iImage.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETIMAGELIST, iImage, himl)
EndProcedure
Procedure TreeView_GetNextItem(*Gadget.cTreeViewOBJ, hItem.l, Flag.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETNEXTITEM, Flag, hItem)
EndProcedure
Procedure TreeView_GetChild(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_CHILD)
EndProcedure
Procedure TreeView_GetNextSibling(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_NEXT)
EndProcedure
Procedure TreeView_GetPrevSibling(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_PREVIOUS)
EndProcedure
Procedure TreeView_GetParent(*Gadget.cTreeViewOBJ, hItem)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_PARENT)
EndProcedure
Procedure TreeView_GetFirstVisible(*Gadget.cTreeViewOBJ)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, #Null, #TVGN_FIRSTVISIBLE)
EndProcedure
Procedure TreeView_GetNextVisible(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_NEXTVISIBLE)
EndProcedure
Procedure TreeView_GetPrevVisible(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, hItem, #TVGN_PREVIOUSVISIBLE)
EndProcedure
Procedure TreeView_GetSelection(*Gadget.cTreeViewOBJ)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, #Null, #TVGN_CARET)
EndProcedure
Procedure TreeView_GetDropHilight(*Gadget.cTreeViewOBJ)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, #Null, #TVGN_DROPHILITE)
EndProcedure
Procedure TreeView_GetRoot(*Gadget.cTreeViewOBJ)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, #Null, #TVGN_ROOT)
EndProcedure
Procedure TreeView_GetLastVisible(*Gadget.cTreeViewOBJ)
  ProcedureReturn TreeView_GetNextItem(*Gadget\hGadget, #Null, #TVGN_LASTVISIBLE)
EndProcedure
Procedure TreeView_Select(*Gadget.cTreeViewOBJ, hItem.l, Flag.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SELECTITEM, Flag, hItem)
EndProcedure
Procedure TreeView_SelectItem(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_Select(*Gadget\hGadget, hItem, #TVGN_CARET)
EndProcedure
Procedure TreeView_SelectDropTarget(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_Select(*Gadget\hGadget, hItem, #TVGN_DROPHILITE)
EndProcedure
Procedure TreeView_SelectSetFirstVisible(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn TreeView_Select(*Gadget\hGadget, hItem, #TVGN_FIRSTVISIBLE)
EndProcedure
Procedure TreeView_GetItem(*Gadget.cTreeViewOBJ, pitem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETITEM, 0, pitem)
EndProcedure
Procedure TreeView_SetItem(*Gadget.cTreeViewOBJ, pitem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETITEM, 0, pitem)
EndProcedure
Procedure TreeView_EditLabel(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_EDITLABEL, 0, hItem)
EndProcedure
Procedure TreeView_GetEditControl(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETEDITCONTROL, 0, 0)
EndProcedure
Procedure TreeView_GetVisibleCount(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETVISIBLECOUNT, 0, 0)
EndProcedure
Procedure TreeView_HitTest(*Gadget.cTreeViewOBJ, lpht.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_HITTEST, 0, lpht)
EndProcedure
Procedure TreeView_CreateDragImage(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_CREATEDRAGIMAGE, 0, hItem)
EndProcedure
Procedure TreeView_SortChildren(*Gadget.cTreeViewOBJ, hItem.l, fRecurse.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SORTCHILDREN, fRecurse, hItem)
EndProcedure
Procedure TreeView_EnsureVisible(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_ENSUREVISIBLE, 0, hItem)
EndProcedure
Procedure TreeView_SortChildrenCB(*Gadget.cTreeViewOBJ, psort.l, fRecurse.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SORTCHILDREN, fRecurse, psort)
EndProcedure
Procedure TreeView_EndEditLabelNow(*Gadget.cTreeViewOBJ, fCancel.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_ENDEDITLABELNOW, fCancel, 0)
EndProcedure
Procedure TreeView_GetISearchString(*Gadget.cTreeViewOBJ, lpsz.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETISEARCHSTRING, 0, lpsz)
EndProcedure
Procedure TreeView_SetToolTips(*Gadget.cTreeViewOBJ, hwndTT.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETTOOLTIPS, hwndTT, 0)
EndProcedure
Procedure TreeView_GetToolTips(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETTOOLTIPS, 0, 0)
EndProcedure
Procedure TreeView_SetInsertMark(*Gadget.cTreeViewOBJ, hItem.l, fAfter.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETINSERTMARK, fAfter, hItem)
EndProcedure
Procedure TreeView_SetUnicodeFormat(*Gadget.cTreeViewOBJ, fUnicode.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETUNICODEFORMAT, fUnicode, 0)
EndProcedure
Procedure TreeView_GetUnicodeFormat(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETUNICODEFORMAT, 0, 0)
EndProcedure
Procedure TreeView_SetItemHeight(*Gadget.cTreeViewOBJ, iHeight.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETITEMHEIGHT, iHeight, 0)
EndProcedure
Procedure TreeView_GetItemHeight(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETITEMHEIGHT, 0, 0)
EndProcedure
Procedure TreeView_SetBkColor(*Gadget.cTreeViewOBJ, clr.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETBKCOLOR, 0, clr)
EndProcedure
Procedure TreeView_SetTextColor(*Gadget.cTreeViewOBJ, clr.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETTEXTCOLOR, 0, clr)
EndProcedure
Procedure TreeView_GetBkColor(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETBKCOLOR, 0, 0)
EndProcedure
Procedure TreeView_GetTextColor(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETTEXTCOLOR, 0, 0)
EndProcedure
Procedure TreeView_SetScrollTime(*Gadget.cTreeViewOBJ, uTime.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETSCROLLTIME, uTime, 0)
EndProcedure
Procedure TreeView_GetScrollTime(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETSCROLLTIME, 0, 0)
EndProcedure
Procedure TreeView_SetInsertMarkColor(*Gadget.cTreeViewOBJ, clr.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETINSERTMARKCOLOR, 0, clr)
EndProcedure
Procedure TreeView_GetInsertMarkColor(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETINSERTMARKCOLOR, 0, 0)
EndProcedure
Procedure TreeView_SetItemState(*Gadget.cTreeViewOBJ, hItem.l, Datan.l, _mask.l)
  _ms_TVi.TVITEM
  _ms_TVi\mask = #TVIF_STATE
  _ms_TVi\hItem = hItem
  _ms_TVi\stateMask = _mask
  _ms_TVi\state = Datan
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETITEM, 0, @TreeView__ms_TVi)
EndProcedure
Procedure TreeView_SetCheckState(*Gadget.cTreeViewOBJ, hItem.l, fCheck.l)
  ;- ?
  If fCheck
    ProcedureReturn TreeView_SetItemState(*Gadget\hGadget, hItem, 2<<12, #TVIS_STATEIMAGEMASK)
  Else
    ProcedureReturn TreeView_SetItemState(*Gadget\hGadget, hItem, 1<<12, #TVIS_STATEIMAGEMASK)
  EndIf
EndProcedure
Procedure TreeView_GetItemState(*Gadget.cTreeViewOBJ, hItem.l, mask.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETITEMSTATE, hItem, mask)
EndProcedure
Procedure TreeView_GetCheckState(*Gadget.cTreeViewOBJ, hItem.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETITEMSTATE, hItem, #TVIS_STATEIMAGEMASK) >> 12 - 1
EndProcedure
Procedure TreeView_SetLineColor(*Gadget.cTreeViewOBJ, clr.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_SETLINECOLOR, 0, clr)
EndProcedure
Procedure TreeView_GetLineColor(*Gadget.cTreeViewOBJ)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_GETLINECOLOR, 0, 0)
EndProcedure
Procedure TreeView_MapHTREEITEMToAccID(*Gadget.cTreeViewOBJ, HTREEITEM.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_MAPHTREEITEMTOACCID, HTREEITEM, 0)
EndProcedure
Procedure TreeView_MapAccIDToHTREEITEM(*Gadget.cTreeViewOBJ, ID.l)
  ProcedureReturn SendMessage_(*Gadget\hGadget, #TVM_MAPACCIDTOHTREEITEM, ID, 0)
EndProcedure




Procedure.l TreeViewNew(GadgetNr.l)
	Protected *g.cTreeViewOBJ
	
	*g = AllocateMemory(SizeOf(cTreeViewOBJ))
	*g\VTable  = *g + OffsetOf(cTreeViewOBJ\f)
	*g\hGadget = GadgetID(GadgetNr)
	
	*g\f[0] = @TreeView_InsertItem()
	*g\f[1] = @TreeView_DeleteItem()
	*g\f[2] = @TreeView_DeleteAllItems()
	*g\f[3] = @TreeView_Expand()
	*g\f[4] = @TreeView_GetItemRect()
	*g\f[5] = @TreeView_GetCount()
	*g\f[6] = @TreeView_GetIndent()
	*g\f[7] = @TreeView_SetIndent()
	*g\f[8] = @TreeView_GetImageList()
	*g\f[9] = @TreeView_SetImageList()
	*g\f[10] = @TreeView_GetNextItem()
	*g\f[11] = @TreeView_GetChild()
	*g\f[12] = @TreeView_GetNextSibling()
	*g\f[13] = @TreeView_GetPrevSibling()
	*g\f[14] = @TreeView_GetParent()
	*g\f[15] = @TreeView_GetFirstVisible()
	*g\f[16] = @TreeView_GetNextVisible()
	*g\f[17] = @TreeView_GetPrevVisible()
	*g\f[18] = @TreeView_GetSelection()
	*g\f[19] = @TreeView_GetDropHilight()
	*g\f[20] = @TreeView_GetRoot()
	*g\f[21] = @TreeView_GetLastVisible()
	*g\f[22] = @TreeView_Select()
	*g\f[23] = @TreeView_SelectItem()
	*g\f[24] = @TreeView_SelectDropTarget()
	*g\f[25] = @TreeView_SelectSetFirstVisible()
	*g\f[26] = @TreeView_GetItem()
	*g\f[27] = @TreeView_SetItem()
	*g\f[28] = @TreeView_EditLabel()
	*g\f[29] = @TreeView_GetEditControl()
	*g\f[30] = @TreeView_GetVisibleCount()
	*g\f[31] = @TreeView_HitTest()
	*g\f[32] = @TreeView_CreateDragImage()
	*g\f[33] = @TreeView_SortChildren()
	*g\f[34] = @TreeView_EnsureVisible()
	*g\f[35] = @TreeView_SortChildrenCB()
	*g\f[36] = @TreeView_EndEditLabelNow()
	*g\f[37] = @TreeView_GetISearchString()
	*g\f[38] = @TreeView_SetToolTips()
	*g\f[39] = @TreeView_GetToolTips()
	*g\f[40] = @TreeView_SetInsertMark()
	*g\f[41] = @TreeView_SetUnicodeFormat()
	*g\f[42] = @TreeView_SetItemHeight()
	*g\f[43] = @TreeView_GetItemHeight()
	*g\f[44] = @TreeView_SetBkColor()
	*g\f[45] = @TreeView_SetTextColor()
	*g\f[46] = @TreeView_GetBkColor()
	*g\f[47] = @TreeView_GetTextColor()
	*g\f[48] = @TreeView_SetScrollTime()
	*g\f[49] = @TreeView_GetScrollTime()
	*g\f[50] = @TreeView_SetInsertMarkColor()
	*g\f[51] = @TreeView_GetInsertMarkColor()
	*g\f[52] = @TreeView_SetItemState()
	*g\f[53] = @TreeView_SetCheckState()
	*g\f[54] = @TreeView_GetItemState()
	*g\f[55] = @TreeView_GetCheckState()
	*g\f[56] = @TreeView_SetLineColor()
	*g\f[57] = @TreeView_GetLineColor()
	*g\f[58] = @TreeView_MapHTREEITEMToAccID()
	*g\f[59] = @TreeView_MapAccIDToHTREEITEM()
	
	ProcedureReturn *g
EndProcedure




; IncludeFile "ooptreeview.pbi"
; 
; 
; 
; OpenWindow(0, 500, 500, 500, 500, #PB_Window_SystemMenu|#PB_Window_ScreenCentered, "TreeView-Test")
; CreateGadgetList(WindowID())
; 	TreeGadget(1, 0, 0, 500, 500, #PB_Tree_AlwaysShowSelection)
; 
; 
; AddGadgetItem(1, -1, "Root1")
; OpenTreeGadgetNode(1)
; 	AddGadgetItem(1, -1, "child2")
; 	AddGadgetItem(1, -1, "child1")
; CloseTreeGadgetNode(1)
; 
; AddGadgetItem(1, -1, "Root2")
; OpenTreeGadgetNode(1)
; 	AddGadgetItem(1, -1, "child1")
; 	
; 	AddGadgetItem(1, -1, "child3")
; 	OpenTreeGadgetNode(1)
; 		AddGadgetItem(1, -1, "child8")
; 		AddGadgetItem(1, -1, "child7")
; 	CloseTreeGadgetNode(1)
; 	
; 	AddGadgetItem(1, -1, "child2")
; CloseTreeGadgetNode(1)
; 
; 
; SetFocus_(GadgetID(1))
; 
; *tv.cTreeView = TreeViewNew(1)
; 
; ; Anzahl Elemente
; count.l = *tv\GetCount()
; ; Itemhöhe auf 33 stellen
; *tv\SetItemHeight(33)
; ; Hintergrundfarbe setzen
; *tv\SetBkColor($FEFFAF)
; ; Rot schreiben
; *tv\SetTextColor($FF)
; ; Pinke Linien
; *tv\SetLineColor($FF00FF)
; ; Einrückung 'etwas' höher stellen
; *tv\SetIndent(100)
; ; Sortiere 2. Root
; *tv\SortChildren(GadgetItemID(1, 3), 0)
; ; Markieren wir mal ne Stelle
; *tv\SetInsertMark(GadgetItemID(1, 5), 0)
; ; Aber in blau!
; *tv\SetInsertMarkColor($FF0000)
; 
; 
; Repeat
; 	
; 	
; Until WaitWindowEvent() = #PB_Event_CloseWindow

That's surely enough for one post, I'll post a second one in a few minutes

remi_meier · Post by **remi_meier** » Sat Sep 24, 2005 8:56 pm

The show must go on!

Simple Turtle Graphics
A class for drawings like fractals.

Code: Select all

Interface ITurtle
	PenDown() ; Draw when moving
	PenUp() ; Don't draw when moving
	MoveTo(x.f, y.f) ; Move to a location (and draw)
	SetColor(Color.l) ; Changes drawing color
	SetDir(Angle.f) ; Sets direction absolute (radian)
	Turn(Angle.f) ; Sets direction relatively (turn by ...)
	Forward(Steps.f) ; Move forward relatively
EndInterface

Structure cTurtle
	VTable.l
	
	; Functions
	fPenDown.l
	fPenUp.l
	fMoveTo.l
	fSetColor.l
	fSetDir.l
	fTurn.l
	fForward.l
	
	; Data
	x.f
	y.f
	angle.f
	pen.l
	color.l
EndStructure


Procedure turtle_PenDown(*this.cTurtle)
	*this\pen = #True
EndProcedure

Procedure turtle_PenUp(*this.cTurtle)
	*this\pen = #False
EndProcedure

Procedure turtle_MoveTo(*this.cTurtle, x.f, y.f)
	*this\x = x
	*this\y = y
EndProcedure

Procedure turtle_SetColor(*this.cTurtle, Color.l)
	*this\color = Color
EndProcedure

Procedure turtle_SetDir(*this.cTurtle, Angle.f)
	*this\angle = Angle
EndProcedure

Procedure turtle_Turn(*this.cTurtle, Angle.f)
	*this\angle + Angle
EndProcedure

Procedure turtle_Forward(*this.cTurtle, Steps.f)
	Protected x.f, y.f
	
	x = *this\x
	y = *this\y
	*this\x + Cos(*this\angle) * Steps
	*this\y + Sin(*this\angle) * Steps
	
	If *this\Pen
		LineXY(x, y, *this\x, *this\y, *this\color)
	EndIf
EndProcedure



Procedure.l new_turtle()
	Protected *t.cTurtle
	
	*t = AllocateMemory(SizeOf(cTurtle))
	*t\VTable = *t + OffsetOf(cTurtle\fPenDown)
	
	*t\fPenDown		= @turtle_PenDown()
	*t\fPenUp			= @turtle_PenUp()
	*t\fMoveTo		= @turtle_MoveTo()
	*t\fSetColor	= @turtle_SetColor()
	*t\fSetDir		= @turtle_SetDir()
	*t\fTurn			= @turtle_Turn()
	*t\fForward		= @turtle_Forward()
	
	ProcedureReturn *t
EndProcedure


Procedure.f D2R(x.f)
	ProcedureReturn x / 360.0 * 2 * 3.1415926
EndProcedure




Global *s.ITurtle

; everyone knows the Sierpinski triangle!
Procedure DrawSierpinski(t, s.f)
	If t = 0
		*s\Forward(s)
	Else
		DrawSierpinski(t - 1, s / 3)
		*s\Turn(D2R(-60))
		DrawSierpinski(t - 1, s / 3)
		*s\Turn(D2R(120))
		DrawSierpinski(t - 1, s / 3)
		*s\Turn(D2R(-60))
		DrawSierpinski(t - 1, s / 3)
	EndIf
EndProcedure

; Koch curve
Procedure DrawKoch(t, s.f)
	If t = 0
		*s\Forward(s)
	Else
		DrawKoch(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawKoch(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawKoch(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawKoch(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawKoch(t - 1, s / 3)
	EndIf
EndProcedure

; Peano curve
Procedure DrawPeano(t, s.f)
	If t = 0
		*s\Forward(s)
	Else
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(-90))
		DrawPeano(t - 1, s / 3)
		*s\Turn(D2R(90))
		DrawPeano(t - 1, s / 3)
	EndIf
EndProcedure

; somthing strange ;)
Procedure DrawTemp1(t, s.f)
	If t = 0
		*s\Forward(s)
	Else
		DrawTemp1(t - 1, s / 3)
		*s\Turn(D2R(-60))
		DrawTemp1(t - 1, s / 3)
		*s\Turn(D2R(-60))
		DrawTemp1(t - 1, s / 3)
		*s\Turn(D2R(60))
		DrawTemp1(t - 1, s / 3)
		*s\Turn(D2R(-60))
		DrawTemp1(t - 1, s / 3)
	EndIf
EndProcedure



img = CreateImage(#PB_Any, 500, 500)

OpenWindow(0, 200,200, 500,500, #PB_Window_SystemMenu|#PB_Window_ScreenCentered, "Turtle")
CreateGadgetList(WindowID())
	ImageGadget(1, 0,0, 500,500, UseImage(img))


*s = new_turtle()
StartDrawing(ImageOutput())

	*s\SetColor($FF)
	*s\PenDown()
	
	
	*s\SetDir(D2R(0))
	*s\MoveTo(50, 100)
	DrawSierpinski(3, 150)
	
	*s\SetDir(D2R(0))
	*s\MoveTo(300, 100)
	DrawKoch(3, 150)
	
	*s\SetDir(D2R(0))
	*s\MoveTo(50, 200)
	DrawPeano(3, 150)
	
	*s\SetDir(D2R(0))
	*s\MoveTo(300, 200)
	DrawTemp1(3, 150)
	
StopDrawing()

SetGadgetState(1, UseImage(img))

Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindow

Now some Algorithms
I know that some of them were postet before, but I don't know which and
if they are as small as these ones:

Bubble Sort
Who doesn't know this one

Code: Select all

; just consult google!
#N=10
Dim a(#N)

Procedure bubble()
  i.l
  j.l
  t.l
  For i=#N To 1 Step -1
    For j=2 To i
      If a(j-1)>a(j)
        t=a(j-1)
        a(j-1)=a(j)
        a(j)=t
      EndIf
    Next
  Next
EndProcedure

Restore daten
For z=1 To #N
  Read a(z)
  k.s+Str(a(z))+" "
Next
Debug k
k=""

bubble()

For z=1 To #N
  k.s+Str(a(z))+" "
Next
Debug k

DataSection
  daten:
    Data.l 5,1,3,9,2,4,6,8,7,0
EndDataSection

Insertion Sort
Another sort routine.

Code: Select all

#N=10
Dim a(#N)

Procedure insertion()
  i.l
  j.l
  v.l
  For i=2 To #N
    v=a(i)
    j=i
    While a(j-1)>v
      a(j)=a(j-1)
      j-1
    Wend
    a(j)=v
  Next
EndProcedure

Restore daten
For z=1 To #N
  Read a(z)
  k.s+Str(a(z))+" "
Next
Debug k
k=""

insertion()

For z=1 To #N
  k.s+Str(a(z))+" "
Next
Debug k

DataSection
  daten:
    Data.l 5,1,3,9,2,4,6,8,7,0
EndDataSection

Quicksort
A must known.

Code: Select all

#N=10
Dim a(#N)

Procedure quicksort(l,r)
  v.l
  t.l
  i.l
  j.l
  If r>l
    v=a(r)
    i=l-1
    j=r
    Repeat
      Repeat
        i+1
      Until a(i)>=v
      Repeat
        j-1
      Until a(j)<=v
      t=a(i)
      a(i)=a(j)
      a(j)=t
    Until j<=i
    a(j)=a(i)
    a(i)=a(r)
    a(r)=t
    quicksort(l,i-1)
    quicksort(i+1,r)
  EndIf
EndProcedure

Restore daten
For z=1 To #N
  Read a(z)
  k.s+Str(a(z))+" "
Next
Debug k
k=""

quicksort(1,#N)

For z=1 To #N
  k.s+Str(a(z))+" "
Next
Debug k

DataSection
  daten:
    Data.l 5,1,3,9,2,4,6,8,7,0
EndDataSection

Selection Sort
Another one...

Code: Select all

#N=10
Dim a(#N)

Procedure selection()
  i.l
  j.l
  min.l
  t.l
  For i=1 To #N-1
    min=i
    For j=i+1 To #N
      If a(j)<a(min)
        min=j
      EndIf
    Next
    t=a(min)
    a(min)=a(i)
    a(i)=t
  Next 
EndProcedure

Restore daten
For z=1 To #N
  Read a(z)
  k.s+Str(a(z))+" "
Next
Debug k
k=""

selection()

For z=1 To #N
  k.s+Str(a(z))+" "
Next
Debug k

DataSection
  daten:
    Data.l 5,1,3,9,2,4,6,8,7,0
EndDataSection

Shellsort
Ugh..

Code: Select all

; a better bubble sort
#N=10
Dim a(#N)

Procedure shellsort()
  i.l
  j.l
  h.l
  v.l
  h=1
  Repeat
    h=3*h+1
  Until h>#N
  
  Repeat
    h=Int(h/3)
    For i=h+1 To #N
      v=a(i)
      j=i
      While a(j-h)>v
        a(j)=a(j-h)
        j=j-h
        If j<=h
          Break
        EndIf
      Wend
      a(j)=v
    Next
  Until h=1
EndProcedure

Restore daten
For z=1 To #N
  Read a(z)
  k.s+Str(a(z))+" "
Next
Debug k
k=""

shellsort()

For z=1 To #N
  k.s+Str(a(z))+" "
Next
Debug k

DataSection
  daten:
    Data.l 5,1,3,9,2,4,6,8,7,0
EndDataSection

Random Numbers
One method of generating random numbers on your own.

Code: Select all

#m=100000000
#m1=10000
#b=31415821

i.l
Global a.l ;Seed value
N.l

Procedure mult(p.l,q.l)
  p1.l
  p0.l
  q1.l
  q0.l
  p1=Int(p/#m1)
  p0=p%#m1
  q1=Int(q/#m1)
  q0=q%#m1
  ProcedureReturn (((p0*q1+p1*q0)%#m1)*#m1+p0*q0)%#m
EndProcedure

Procedure myrandom(r)  ;r=max
  a=(mult(a,#b)+1)%#m
  ProcedureReturn Int((Int(a/#m1)*r)/#m1)+1  ;zahlen von 1 bis r
EndProcedure

N=10
a=Random(12135)   ;set seed value
For i=1 To N
  Debug myrandom(11)  
Next

And another post ended...

remi_meier · Post by **remi_meier** » Sat Sep 24, 2005 9:04 pm

Can't post them all, but the most important ones...

Reversed Polish Notation
How to translate 3+4*5 into 3 4 5 * +

Code: Select all

; a really extended code can be found in my CH++ compiler where
; there are more operators, variables, functions and of course an ASM
; output :D
Structure TOKENS
  s.s     ; Content
  Typ.s   ; "op", "int", "par"
EndStructure

NewList Tokens.TOKENS()

Procedure SCIsOperator(s.s)
  Protected ReturnValue.l
  
  ;/ check if it is a known parameter
  
  ReturnValue = #False
  
  If Len(s) = 1
    Select PeekB(@s)
      Case '+'
        ReturnValue = #True
      Case '-'
        ReturnValue = #True
      Case '*'
        ReturnValue = #True
      Case '/'
        ReturnValue = #True
      Case '.'
        ReturnValue = #True
    EndSelect
  EndIf
  
  ProcedureReturn ReturnValue
EndProcedure

Procedure SCIsKlammer(s.s)
  Protected *p.BYTE, ReturnValue.l
  
  ;/ Is it a paranthesis?
  
  If Len(s) = 1
    *p = @s
    
    ReturnValue = #False
    
    If *p\b = '(' Or *p\b = ')'
      ReturnValue = #True
    EndIf
  EndIf
  
  ProcedureReturn ReturnValue
EndProcedure

Procedure SCIsInteger(s.s)
  Protected *p.BYTE, ReturnValue.l
  *p = @s
  
  ;/ Is it a number?
  
  ReturnValue = #False
  
  If *p\b <> 0
    While *p\b <> 0
      If (*p\b < 48 Or *p\b > 57)
        Break
      EndIf
      
      *p + 1
    Wend
    
    If *p\b = 0 And *p\b <> @s + 1
      ReturnValue = #True
    EndIf
  EndIf
  
  ProcedureReturn ReturnValue 
EndProcedure

Procedure CleanSCOutput()
  ;/ Concats multi digit numbers to one integer
  ;/ because now, 23 would be 2 and 3 in seperate tokens!
  
  Protected WasInt.l, LastInt.s
  
  ForEach Tokens()
    If Tokens()\Typ = "int" Or Tokens()\s = "."
      If WasInt = #True
        LastInt = Tokens()\s
        DeleteElement(Tokens())
        Tokens()\s + LastInt
      EndIf
      WasInt = #True
    Else
      WasInt = #False
    EndIf
  Next
EndProcedure

Procedure Scanner(String.s)
  Protected Len.l, Start.l, z.l, s.s
  
  ;/ Tokenizes the string and writes it in a list
  
  Len = Len(String)
  Start = 1
  ; Add paranthesis around expressions (needed for Reversed Polnish Notation)
  AddElement(Tokens())
  Tokens()\s   = "("
  Tokens()\Typ = "par"
  For z = 1 To Len + 1
    s = ReplaceString( Mid(String, Start, z - Start), Chr(9), " ")
    
    If s = " "
      s = ""
      Start + 1
      
    ElseIf s = ""
      Continue
      
    ElseIf SCIsOperator(s)
      AddElement(Tokens())
      Tokens()\Typ    = "op"
      Tokens()\s      = s
      Start + 1
      s = ""
      
    ElseIf SCIsInteger(s)
      AddElement(Tokens())
      Tokens()\Typ    = "int"
      Tokens()\s      = s
      Start + Len(s)
      s = ""
      
    ElseIf SCIsKlammer(s)
      AddElement(Tokens())
      Tokens()\Typ    = "par"
      Tokens()\s      = s
      Start + 1
      s = ""
      
    EndIf
  Next
  
  AddElement(Tokens())
  Tokens()\s   = ")"
  Tokens()\Typ = "par"
  
  CleanSCOutput()
EndProcedure



;- Main part for the Reversed Polish Notation
NewList Symbols.TOKENS()
NewList PStack.TOKENS()

Procedure GetPrecedence(*Token.TOKENS)
  Protected ReturnValue.l
  
  ;/ Returns the precedence of the operators and paranthesis
  
  Select *Token\Typ
    Case "op"
      Select *Token\s
        Case "+"
          ReturnValue = 3
        Case "-"
          ReturnValue = 3
        Case "*"
          ReturnValue = 4
        Case "/"
          ReturnValue = 4
      EndSelect
    Case "par"
      ReturnValue = 5
  EndSelect
  
  ProcedureReturn ReturnValue
EndProcedure

Procedure PParseExpression()
  
  ;/ Main part: Reverses the tokens according to the precedence of operators
  ;/ instead of 3 + 4 -> 3 4 +
  ;/ or 3 * (4 + 5) -> 3 4 5 + *
  
  ClearList(Symbols())
  ClearList(PStack())
  
  ForEach Tokens()
    
    If Tokens()\s = "("
      ; Push on stack
      AddElement(PStack())
      PStack()\s      = Tokens()\s
      PStack()\Typ    = Tokens()\Typ
      
    ElseIf Tokens()\s = ")"
      ; Pop off stack as long as we are inside paranthesis
      While PStack()\s <> "("
        AddElement(Symbols())
        Symbols()\s      = PStack()\s
        Symbols()\Typ    = PStack()\Typ
        DeleteElement(PStack())
      Wend
      
      If PStack()\s = "("
        DeleteElement(PStack())
      EndIf
      
    ElseIf Tokens()\Typ = "op"
      ; If it is an operator
      Repeat
        
        ; If stack is empty, element on stack is '(' or if the element on stack
        ; has a lower priority than the current one
        If CountList(PStack()) = 0 Or PStack()\s = "(" Or GetPrecedence(@PStack()) < GetPrecedence(@Tokens())
          ; Push current element and break!
          AddElement(PStack())
          PStack()\s      = Tokens()\s
          PStack()\Typ    = Tokens()\Typ
          Break
          
        Else
          ; Write it to symbols!
          AddElement(Symbols())
          Symbols()\s      = PStack()\s
          Symbols()\Typ    = PStack()\Typ
          DeleteElement(PStack())
        EndIf
      ForEver
      
    Else
      ; If it is an integer, immediately write to Symbols
      AddElement(Symbols())
      Symbols()\s      = Tokens()\s
      Symbols()\Typ    = Tokens()\Typ
      
    EndIf
    
  Next
  
EndProcedure



Procedure OutputTokens()
  ForEach Tokens()
    Debug Tokens()\s
  Next
EndProcedure

Procedure OutputSymbols()
  ForEach Symbols()
    Debug Symbols()\s
  Next
EndProcedure



String.s = "3.0 + 4.0 * (5 + 23.0)"
Scanner(String)
Debug "##### Scanned #####"
OutputTokens()
PParseExpression()
Debug "##### Reversed #####"
OutputSymbols()

IncludeFile "Calculator.pbi" ; Code below!

Debug "##### Resultat #####"
Debug CalcExpr()

And the calculator
for the code above

Code: Select all

;/ And the calculator

NewList CStack.f()

Procedure.f CalcExpr()
  
  ClearList(CStack())
  ForEach Symbols()
    If Symbols()\Typ = "int"
      AddElement(CStack())
      CStack() = ValF(Symbols()\s)
      
    ElseIf Symbols()\Typ = "op"
      Res.f = 0
      op2.f = CStack()
      DeleteElement(CStack())
      op1.f = CStack()
      Select Symbols()\s
        Case "+"
          Res = op1 + op2
        Case "-"
          Res = op1 - op2
        Case "*"
          Res = op1 * op2
        Case "/"
          Res = op1 / op2
      EndSelect
      
      CStack() = Res
      
    EndIf
    
  Next
  
  ProcedureReturn CStack()
EndProcedure

Little Calculator
With a recursive approach

Code: Select all

; just another method to get a result, not suitable for compilers!
Procedure.s GetContent(String.s, Pos.l, First.b, Last.b) ;String = "dd(hallo)xyz", 3, '(', ')'
  Protected Content.s, *p.BYTE, AnzKl.l
  *p = @String + Pos
  While *p\b
    If *p\b = First
      AnzKl.l + 1
    ElseIf *p\b = Last
      AnzKl - 1
      If AnzKl <= -1
        Break
      EndIf
    EndIf
    Content + Chr(*p\b)
    *p + 1
  Wend
  
  ProcedureReturn Content
EndProcedure

Procedure.s CalcBiExpression(ContL.s, Op.s, ContR.s) ; A+b oder A*b ...
  Protected Result.s
  
  Select Op
    Case "*"
      Result = Str(Val(ContL) * Val(ContR))
    Case "/"
      Result = Str(Val(ContL) / Val(ContR))
    Case "+"
      Result = Str(Val(ContL) + Val(ContR))
    Case "-"
      Result = Str(Val(ContL) - Val(ContR))
  EndSelect
  
  
  ProcedureReturn Result.s
EndProcedure


Procedure.s ProcessExpression(Exp.s)
  Protected *p.BYTE, v.s, zw.l, ContL.s, ContR.s, Op.s, Cont.s
  *p = @Exp
  
  
  ;/ Search for ()
  While *p\b
    If *p\b = '('
      Cont = GetContent(Exp, *p-@Exp+1, '(', ')')
      v.s = ProcessExpression(Cont)
      Exp = ReplaceString(Exp, "("+Cont+")", v)
      *p  = @Exp
    ElseIf *p\b = ')'
      Debug "Fehler: Klammer nicht geöffnet!"
    EndIf
    *p + 1
  Wend
  
  
  ;/ Search for * and /
  *p = @Exp
  While *p\b
    If *p\b = '*' Or *p\b = '/'
      zw = *p ;Zwischenspeichern
      Op = Chr(*p\b)
      ; Gehe zurück bis ein Operator kommt
      *p - 1
      ContL = ""
      While *p\b <> '*' And *p\b <> '/' And *p\b <> '+' And *p\b <> '-' And *p\b 
        ContL = Chr(*p\b) + ContL
        *p - 1
      Wend
      
      *p = zw
      
      ; Forward till operator
      *p + 1
      ContR = ""
      While *p\b <> '*' And *p\b <> '/' And *p\b <> '+' And *p\b <> '-' And *p\b 
        ContR = ContR + Chr(*p\b)
        *p + 1
      Wend
      
      v = CalcBiExpression(ContL, Op, ContR)
      Exp = ReplaceString(Exp, ContL+Op+ContR, v)
      *p = @Exp
    EndIf
    *p + 1
  Wend
  
  ;/ Search for + and -
  *p = @Exp
  While *p\b
    If *p\b = '+' Or *p\b = '-'
      zw = *p ;Zwischenspeichern
      Op = Chr(*p\b)
      ; Gehe zurück bis ein Operator kommt
      *p - 1
      ContL = ""
      While *p\b <> '*' And *p\b <> '/' And *p\b <> '+' And *p\b <> '-' And *p\b 
        ContL = Chr(*p\b) + ContL
        *p - 1
      Wend
      
      *p = zw
      
      ; Forward till operator
      *p + 1
      ContR = ""
      While *p\b <> '*' And *p\b <> '/' And *p\b <> '+' And *p\b <> '-' And *p\b 
        ContR = ContR + Chr(*p\b)
        *p + 1
      Wend
      
      v = CalcBiExpression(ContL, Op, ContR)
      Exp = ReplaceString(Exp, ContL+Op+ContR, v)
      *p = @Exp
    EndIf
    *p + 1
  Wend
  
  
  ProcedureReturn Exp
EndProcedure




Expression.s = "(2*2)+2*(3+4*(4+1))*2"
Expression = RemoveString(Expression, " ") ;im Parser
Res.s = ProcessExpression(Expression)
Debug "#############  RESULT  #############"
Debug Res

Rho-Algorithm
Yes, I know, very little, but powerful!

Code: Select all

; Rho-Algorithmus
; For finding cycles in sequencies of numbers defined by a recursive function
Procedure.l F(x.l)
	If x & 1
		ProcedureReturn 3 * x + 1
	Else			
		ProcedureReturn x / 2
	EndIf	
EndProcedure


For z = 1 To 10
	z1 = z
	z2 = z	
	Debug "###"	
	Repeat
		z1 = F(z1)
		z2 = F(F(z2))
		Debug z1		
	Until z1 = z2 Or z2 = 1
Next

I think for the neural networks I'll spend another post

remi_meier · Post by **remi_meier** » Sat Sep 24, 2005 9:20 pm

So... Ever heard of Neural Networks?
Here they are (not all

)

Very simple Example
Just recognize an 'A'
Sry for the German comments...

Code: Select all

;"A"-Recognization with Neural Network (NN)


#n  = 10      ;length of side  (#n*#n = Count of inputs)
#LK = 0.1     ;learning constant  (how fast the NN is learning, between 0 and 1 (0.1 = slow))
#SF = 0.2     ;Noise < 0.5  (to interfere the image)
#LD = 10000   ;learning cycles  (how many times learning?)


Dim inputs(#n * #n)                   ;Array for inputs
Global ist_output.f, soll_output.f    ;global vars for outputs
; ist=actually calculated;   soll=should be

Dim gewicht.f(#n * #n)                ;Weights, how strong the inputs of the inputs should be weighted
Global delta_gewicht.f                ;how strong they shall be adjusted


Dim zeichen_A(#n * #n)    ;The images of characters
Dim zeichen_B(#n * #n)
Dim zeichen_C(#n * #n)
Dim zeichen_D(#n * #n)

Restore zeichen_a         ;Fill the arrays
For z = 1 To #n * #n
  Read zeichen_A(z)
Next
Restore zeichen_b
For z = 1 To #n * #n
  Read zeichen_B(z)
Next
Restore zeichen_c
For z = 1 To #n * #n
  Read zeichen_C(z)
Next
Restore zeichen_d
For z = 1 To #n * #n
  Read zeichen_D(z)
Next




Procedure init ()   ;set Weights as random values 0.0-1.0
  z.l
  RandomSeed(5)
  For z = 1 To #n * #n
    gewicht(z) = Random(100) / 100.0
  Next
EndProcedure



Procedure generiere_input ()   ;Fill inputs() with the character-arrays and generate soll_output (should output)
  z.l
  entscheidung.f
  
  soll_output = 0
  entscheidung = Random(100) / 100.0
  If entscheidung < 1 / 5
    soll_output = 1
    For z = 1 To #n * #n
      inputs(z) = zeichen_A(z)
    Next
  ElseIf entscheidung < 2 / 5
    For z = 1 To #n * #n
      inputs(z) = zeichen_B(z)
    Next
  ElseIf entscheidung < 3 / 5
    For z = 1 To #n * #n
      inputs(z) = zeichen_C(z)
    Next
  ElseIf entscheidung < 4 / 5
    For z = 1 To #n * #n
      inputs(z) = zeichen_D(z)
    Next
  Else                         ;Noise array
    For z = 1 To #n * #n
      inputs(z) = 0
      If Random(100) / 100.0 < 2 * #SF
        inputs(z) = 1
      EndIf
    Next
  EndIf
  
  For z = 1 To #n * #n         ;adds a noise to the array
    If Random(100) / 100.0 < #SF
      inputs(z) = 1 - inputs(z)
    EndIf
  Next
  
EndProcedure

Procedure berechne_output ()
  z.l
  
  ist_output = 0
  For z = 1 To #n * #n
    ist_output + inputs(z) * gewicht(z)   ;calculate ist_output
  Next
  
  If ist_output < 0     ;ist_output is 0 or 1
    ist_output = 0
  ElseIf ist_output > 1
    ist_output = 1
  EndIf
  
EndProcedure

Procedure lernen ()
  z.l
  
  delta_gewicht = #LK * (soll_output - ist_output)   ;calculate adjustment of weights
  
  For z = 1 To #n * #n
    gewicht(z) + delta_gewicht * inputs(z)    ;adjust each weight individually
  Next
  
EndProcedure




OpenConsole()

init()
falsch.l = 0
richtig.l = 0

For k = 1 To #LD
  generiere_input()
  berechne_output()
  lernen()
  
  If ist_output > 0.5
    ist_outputger.b = #True
  Else
    ist_outputger.b = #False
  EndIf
  
  If ist_outputger = soll_output
    richtig + 1
  Else
    falsch + 1
  EndIf
Next

PrintN("Richtig: " + Str(richtig))
PrintN("Falsch: "  + Str(falsch))
PrintN(StrF(richtig * 100.0 / #LD) + "% richtig")

Input()





DataSection
zeichen_a:
Data.l 0,0,0,0,0,0,0,0,0,0
Data.l 0,0,0,0,1,1,0,0,0,0
Data.l 0,0,0,1,0,0,1,0,0,0
Data.l 0,0,0,1,0,0,1,0,0,0
Data.l 0,0,1,0,0,0,0,1,0,0
Data.l 0,0,1,1,1,1,1,1,0,0
Data.l 0,0,1,0,0,0,0,1,0,0
Data.l 0,1,0,0,0,0,0,0,1,0
Data.l 0,1,0,0,0,0,0,0,1,0
Data.l 1,0,0,0,0,0,0,0,0,1

zeichen_b:
Data.l 1,1,1,1,1,0,0,0,0,0
Data.l 1,1,0,0,0,1,0,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,1,1,1,1,0,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,0,0,0,1,0,0,0,0
Data.l 1,1,0,0,1,0,0,0,0,0
Data.l 1,1,1,1,0,0,0,0,0,0

zeichen_c:
Data.l 0,0,0,0,0,0,0,0,0,0
Data.l 0,0,0,0,1,1,1,1,1,0
Data.l 0,0,1,1,0,0,0,0,0,0
Data.l 0,1,1,0,0,0,0,0,0,0
Data.l 0,1,1,0,0,0,0,0,0,0
Data.l 0,1,1,0,0,0,0,0,0,0
Data.l 0,1,1,0,0,0,0,0,0,0
Data.l 0,0,1,1,0,0,0,0,0,0
Data.l 0,0,0,0,1,1,1,1,1,0
Data.l 0,0,0,0,0,0,0,0,0,0

zeichen_d:
Data.l 0,0,0,0,0,0,0,0,0,0
Data.l 1,1,1,1,0,0,0,0,0,0
Data.l 1,1,0,0,1,0,0,0,0,0
Data.l 1,1,0,0,0,1,0,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,0,0,0,0,1,0,0,0
Data.l 1,1,0,0,0,1,0,0,0,0
Data.l 1,1,0,0,1,0,0,0,0,0
Data.l 1,1,1,1,0,0,0,0,0,0
Data.l 0,0,0,0,0,0,0,0,0,0

EndDataSection

Ellipses?
Recognize ellipses:

Code: Select all

;Recognize ellipses with NN


; for description of variables and arrays see code above
#n  = 32    
#LK = 0.1 
#SF = 0.1  
#LD = 2000  
#TD = 300  

Dim statistik(#LD) ; statistics


Dim inputs(#n * #n)                 
Global ist_output.f, soll_output.f  

Dim gewicht.f(#n * #n)        
Global delta_gewicht.f    


CreateImage(1,#n,#n)



Procedure init ()   ;set random values for weights
  z.l
  RandomSeed(5)
  For z = 1 To #n * #n
    gewicht(z) = Random(100) / 100
  Next
EndProcedure



Procedure generiere_input ()   ;Fill inputs() with ellipses and boxes and calculate soll_output
  z.l
  entscheidung.f
  
  soll_output = 0
  entscheidung = Random(1)
  
  
  
  StartDrawing(ImageOutput())
    DrawingMode(0)
    Box(0,0,#n,#n,0)
    DrawingMode(4)
    
    If entscheidung = 0  ;if ellipse
      soll_output = 1
      
      Ellipse(#n / 2 + Random(3),#n / 2 + Random(3), 5 + Random(#n / 4), 5 + Random(#n / 4), $FFFFFF)
    Else   ;draw box
      Box(2 + Random(3), 2 + Random(3), 9 + Random(#n / 2), 9 + Random(#n / 2), $FFFFFF)
    EndIf
    
    
    For z = 1 To #n * #n         ;add noise
      If Random(100) < #SF * 100
        If Point(z % #n,Int(z / #n)) > 0
          Plot(z % #n,Int(z / #n),0)
        Else
          Plot(z % #n,Int(z / #n),$FFFFFF)
        EndIf
      EndIf
    Next
    
  StopDrawing()
  
  StartDrawing(ImageOutput())
  For z = 1 To #n * #n
    If Point(z % #n,Int(z / #n)) > 0
      inputs(z) = 1
    Else
      inputs(z) = 0
    EndIf
  Next
  StopDrawing()
  
  
  
EndProcedure

Procedure berechne_output ()
  z.l
  
  ist_output = 0
  For z = 1 To #n * #n
    ist_output + inputs(z) * gewicht(z)   ;calc ist_output
  Next
  
  If ist_output < 0     ;ist_output 0 or 1
    ist_output = 0
  ElseIf ist_output > 1
    ist_output = 1
  EndIf
  
EndProcedure

Procedure lernen ()
  z.l
  f.l = soll_output - ist_output
  delta_gewicht = #LK * f   ;calc main adjustement of weights
  
  For z = 1 To #n * #n
    gewicht(z) + delta_gewicht * inputs(z)
  Next
  
EndProcedure




OpenConsole()
OpenWindow(1,400,500,100,100,#PB_Window_SystemMenu,"")



init()
falsch.l = 0 ;wrong
richtig.l = 0 ;right

For k = 1 To #LD
  generiere_input()
  berechne_output()
  lernen()
  
  If ist_output > 0.5
    ist_outputger.b = #True
  Else
    ist_outputger.b = #False
  EndIf
  
  If ist_outputger = soll_output
    richtig + 1
    statistik(richtig + falsch) = 1
  Else
    falsch + 1
    statistik(richtig + falsch) = 0
  EndIf
  
  StartDrawing(WindowOutput())
    DrawImage(ImageID(),1,1)
    StopDrawing()
  WindowEvent()
Next

PrintN("Learning:")
PrintN("Right: " + Str(richtig))
PrintN("Wrong: "  + Str(falsch))
PrintN(StrF(richtig * 100.0 / #LD) + "% right while learning")
PrintN("")

richtig = 0
falsch  = 0

For z = 1 To #TD
  generiere_input()
  berechne_output()
  
  If ist_output > 0.5
    ist_outputger.b = #True
  Else
    ist_outputger.b = #False
  EndIf
  
  If ist_outputger = soll_output
    richtig + 1
  Else
    falsch + 1
  EndIf
Next

PrintN("Test")
PrintN("Right: " + Str(richtig))
PrintN("Wrong: "  + Str(falsch))
PrintN(StrF(richtig * 100.0 / #TD) + "% right while testing")

Repeat
  StartDrawing(WindowOutput())
    DrawImage(ImageID(),1,1)
    
    schritt = Int(#LD / 90)
    While z <= #LD
      If statistik(z) = 1
        Plot(x + 10,50,$FF00)
      Else
        Plot(x + 10,90,$FF)
      EndIf
      x + 1
      z + schritt
    Wend
    
  StopDrawing()
Until WaitWindowEvent() = #PB_Event_CloseWindow

Like to take the Average?
Code to create the best fitting line through some points (has sometimes
some problems)

Code: Select all

;equation of straight lines: y = m * x + c
;
;Structure of NN:
;
; 1   
;   \c
;     \ output = y
;     /
;   /m
; x
;

#LK = 0.01     ;Learning constant (small!)
#LD = 10000    ;Learning cycles

Dim gewichte.f(2)
gewichte(1) =  0.2   ;random value for 'c'
gewichte(2) = -0.2   ;'m'

Dim inputs.f(2)
inputs(1) = 1  ;always 1, because c = c
               ;inputs(2) = x



Dim Daten.f(10)   ;data which represents a line (approximately)

Daten(1) = 205
Daten(2) = 180
Daten(3) = 175
Daten(4) = 210
Daten(5) = 220
Daten(6) = 190
Daten(7) = 201
Daten(8) = 195
Daten(9) = 215
Daten(10)= 205

; Daten(1) = 10
; Daten(2) = 33
; Daten(3) = 49
; Daten(4) = 75
; Daten(5) = 105
; Daten(6) = 110
; Daten(7) = 129
; Daten(8) = 156
; Daten(9) = 175
; Daten(10)= 190

; Daten(1) = 190
; Daten(2) = 170
; Daten(3) = 155
; Daten(4) = 129
; Daten(5) = 111
; Daten(6) = 92
; Daten(7) = 65
; Daten(8) = 52
; Daten(9) = 29
; Daten(10)= 10


For k = 1 To #LD  ;Learn
  For z = 1 To 10
    inputs(2)    = z ;is x
    ist_output.f = 0 ;is y
    ist_output   = gewichte(2) * inputs(2) + gewichte(1) ;* inputs(1)= 1  ;m*x + c*1 = y
    
    If ist_output > Daten(z) + 10     ;interpolate as much as possible
      ist_output = Daten(z)  + 10     ;else the NN would be confused
    ElseIf ist_output < Daten(z) - 10 ;can be removed with a better learning method
      ist_output = Daten(z)  - 10
    EndIf
    
    soll_output.f = Daten(z)  ;that's what should be calculated
    delta_w.f = #LK * (soll_output - ist_output)  ;main adjustment
    
  
    gewichte(1) + delta_w ;* inputs(1)= 1 
    gewichte(2) + delta_w * inputs(2)  ;individual adjustment
  Next
Next

m.f = gewichte(2)  ;is m
c.f = gewichte(1)  ;is c
Debug m
Debug c
endx.f = 10            ;ending point for straight line
endy.f = m * endx      ;calc

OpenWindow(0,400,300,250,250,#PB_Window_SystemMenu,"Interpolation")

Repeat
  StartDrawing(WindowOutput())
    For z = 1 To 10
      Plot(z * 20 + 10, 240 - Daten(z),$FF0000)    ;Data as points
    Next
    
    
    Line(10,240 - c,Int(endx * 20),Int(-endy),$FF) ;draw line
  
  StopDrawing()
Until WaitWindowEvent() = #PB_Event_CloseWindow

See some Numbers
More complex one

Code: Select all

;Recognize Digits

; See description of variables in code above
#n  = 32 
#SF = 0.2 
#LK = 0.08  
#LD = 2000  
#TD = 1000  ;count of test cycles

Dim inputs(#n * #n - 1)        ;#n * #n inputs for 10 NN

Dim gewichte.f(9, #n * #n - 1) ;10 NN (0-9) with #n * #n weights

Dim ist_output.f(9)            ;ist_output for each of the 10 NN
Dim soll_output.f(9)           ;soll_output for each of the 10 NN
                               ;(i.c. soll_output(4) = 1 if Ziffer = 4, all others are 0)

CreateImage(0, #n, #n)         ;Image for drawing
LoadFont(0,"Courier",#n - 2)   ;Drawing font


Procedure init()
  For z1 = 0 To 9
    For z2 = 0 To #n
      gewichte(z1,z2) = Random(100) / 100 ;Random values
    Next
  Next
EndProcedure

Procedure generiere_input()
  
  entscheidung = Random(9) ;which digit
  For z = 0 To 9
    If entscheidung  = z ; set soll_output
      soll_output(z) = 1  
    Else                 
      soll_output(z) = 0
    EndIf
  Next
  
  StartDrawing(ImageOutput())
  DrawingMode(0)    
  Box(0,0,#n,#n,0)        ;Clearimage
  
  DrawingMode(4)
  Locate(0,-1)
  DrawingFont(FontID())
  BackColor(0,0,0)
  FrontColor(255,255,255)
  DrawText(Chr(entscheidung + 48))  ;draw digit
  
  For z = 1 To #n * #n         ;add noise
    If Random(100) / 100.0 < #SF
      If Point(z % #n,Int(z / #n) + 1) > 0 ;change pixel color
        Plot(z % #n,Int(z / #n) + 1,0)
      Else
        Plot(z % #n,Int(z / #n) + 1,$FFFFFF)
      EndIf
    EndIf
  Next
  
  For z = 0 To #n * #n - 1        ;Fill inputs() with image
    If Point(z % #n,Int(z / #n) + 1) > 0
      inputs(z) = 1
    Else
      inputs(z) = 0
    EndIf
  Next
  
  StopDrawing()
  
EndProcedure

Procedure berechne_output()
  
  For z1 = 0 To 9         ;foreach net
    ist_output(z1) = 0    ;init
    For z2 = 0 To #n * #n - 1
      ist_output(z1) + inputs(z2) * gewichte(z1, z2)  ;calc ist_output with activation rule
    Next
    
    If ist_output(z1) < 0     
      ist_output(z1) = 0      
    ElseIf ist_output(z1) > 1  
      ist_output(z1) = 1
    EndIf
  Next 
  
EndProcedure


Procedure lernen()
  
  For z1 = 0 To 9
    delta_w.f = #LK * (soll_output(z1) - ist_output(z1))  ;Delta-rule
    For z2 = 0 To #n * #n - 1
      gewichte(z1,z2) + delta_w * inputs(z2)   
    Next
  Next
  
EndProcedure


init()

richtig = 0
falsch  = 0

For z = 1 To #LD
  generiere_input() ;fill inputs() and soll_output() 
  berechne_output() ;calc ist_output() 
  lernen()          ;adjust weights
  
  ;Statistics
  max_ist_output.f = 0
  max_ziffer_nr    = -1
  
  For z1 = 0 To 9
    If ist_output(z1) > max_ist_output  ;search for maximum in activation in NNs
      max_ist_output = ist_output(z1)
      max_ziffer_nr  = z1
    EndIf
  Next
  
  If max_ziffer_nr >= 0 And soll_output(max_ziffer_nr) = 1 ; if recognized
    richtig + 1
  Else
    falsch  + 1
  EndIf
  
Next



OpenConsole()
PrintN("Learning")
PrintN("Right: " + Str(richtig))
PrintN("Wrong:  " + Str(falsch))
PrintN("")
PrintN("Percent of rights: " + StrF(richtig * 100 / #LD) + "%")
PrintN("")
PrintN("")


;##################STATISTICS###################

OpenWindow(1,400,600,200,200,#PB_Window_SystemMenu,"")

richtig = 0
falsch  = 0

For z = 1 To #TD
  generiere_input()
  berechne_output()
  max_ist_output = 0
  max_ziffer_nr  = -1
  
  For z1 = 0 To 9
    If ist_output(z1) > max_ist_output
      max_ist_output = ist_output(z1)
      max_ziffer_nr  = z1
    EndIf
  Next
  
  If max_ziffer_nr >= 0 And soll_output(max_ziffer_nr) = 1
    richtig + 1
  Else
    falsch  + 1
  EndIf
  
  StartDrawing(WindowOutput())
  DrawImage(ImageID(),0,0,64,64)
  StopDrawing()
  WindowEvent()
Next

PrintN("Test")
PrintN("Right: " + Str(richtig))
PrintN("Wrong:  " + Str(falsch))
PrintN("")
PrintN("Percentage of rights: " + StrF(richtig * 100 / #TD) + "%")

Repeat
  StartDrawing(WindowOutput())
  DrawImage(ImageID(),0,0,64,64)
  StopDrawing()
Until WaitWindowEvent() = #PB_Event_CloseWindow

Go complex!
Want a 3-layer-NN? Needs a lot of CPU and _time_!!

Code: Select all

;/ 3-layered NN
; Input layer - covered layer - output layer
; - each neuron of the input layer is connected with each of the covered ones
; - each neuron of the covered layer is connected with each of the output ones
; - each neuron of the covered and the output layer has a shifting weight where input is always 1.0

; Activation function is the non linear simoid function:
; 1 / (1 + e^(-Activation))
; always between 0 and 1

; for #LD: for an error of 10% we have to choose a 10 times higher value as 
; the count of weights!! (weights = #v*(#n*#n+#a))

; variable description in code above
#LD = 77100 
#TD = 400  
#LK = 0.1 
#n  = 16  
#v  = 300   ;count of covered neurons
#a  = 1     ;count of outputs (neurons)


;weights
Dim Gewichte1.f(#n * #n, #v)   ;from inputs to covered layer
Dim Gewichte2.f(#v, #a)   ;from covered to output layer
;outputs of neurons
Dim Inputs.f(#n * #n)    ;input neurons
Dim VNeurons.f(#v)  ;covered neurons
Dim VFehler.f(#v)   ;to store adjustment
Dim Outputs.f(#a)   ;Output neurons
Dim OFehler.f(#a)   ;to store adjustment

Dim SollOutputs.f(#a)  ;soll_output


;- Init
Procedure Init_Gewichte()  ;Randomly fill with -0.3 to +0.3
  For z1 = 0 To #n * #n  ;from 0, because we have a shifting weight
    For z2 = 0 To #v
      Gewichte1(z1, z2) = Random(600) / 1000.0 - 0.3
    Next
  Next
  
  For z1 = 0 To #v
    For z2 = 0 To #a
      Gewichte2(z1, z2) = Random(600) / 1000.0 - 0.3
    Next
  Next
  
  VNeurons(0) = 1
  Inputs(0)  = 1
EndProcedure


;- generate input
Global Image.l
Image = CreateImage(#PB_Any, #n, #n)

Procedure Generiere_Input()
  StartDrawing(ImageOutput())
    DrawingMode(0)
    Box(0, 0, #n, #n, 0) 
    DrawingMode(4)
    zufall = Random(1)
    If zufall = 0         ;Ellipse
      Ellipse(Random(4) + 6, Random(4) + 6, Random(4) + 3, Random(4) + 3, $FFFFFF)
      SollOutputs(1) = 1.0    ;Outputneuron = 1
    ElseIf zufall = 1     ;Box
      Box(Random(6), Random(6), Random(5) + 5, Random(5) + 5, $FFFFFF)
      SollOutputs(1) = 0.0    ;Outputneuron = 0
    EndIf
    
    For z = 1 To #n * #n  ;fill Inputs()-Array
      x = (z % #n) + 1
      y = z / #n
      farbe = Point(x, y)
      If farbe > 0
        Inputs(z) = 1.0
      Else
        Inputs(z) = 0.0
      EndIf
    Next
  StopDrawing()
EndProcedure


;- Calculate/Learn/Adjust
Procedure Berechne_Outputs()   ;forward
  For z1 = 1 To #v     ;foreach covered neuron
    VNeurons(z1) = 0     ;init
    For z2 = 1 To #n * #n   ;foreach input neuron
      VNeurons(z1) = VNeurons(z1) + Inputs(z2) * Gewichte1(z2, z1)    ;calc activation (sum)
    Next
    For z3 = 1 To #v    ;shifting weights
      VNeurons(z1) = VNeurons(z1) + Gewichte1(0, z3)
    Next
    VNeurons(z1) = 1.0 / (1.0 + Pow(2.718, -VNeurons(z1)))  ;activation function (sigmoid function) => Output
  Next
  
  For z1 = 1 To #a     ;foreach output neuron
    Outputs(z1) = 0    ;init
    For z2 = 1 To #v     ;foreach covered neuron
      Outputs(z1) = Outputs(z1) + VNeurons(z2) * Gewichte2(z2, z1)
    Next
    For z3 = 1 To #a 
      Outputs(z1) = Outputs(z1) + Gewichte2(0, z3)
    Next
    Outputs(z1) = 1.0 / (1.0 + Pow(2.718, -Outputs(z1)))    
  Next
EndProcedure

Procedure.f Berechne_Fehler() 
  Protected MaxFehler.f  
  
  For z = 1 To #a   ;adjustment for second layer
    OFehler(z) = (SollOutputs(z) - Outputs(z)) * Outputs(z) * (1.0 - Outputs(z))    ;fill adjustment array for output layer
  Next
  
  For z1 = 1 To #v    ;foreach covered layer
    Fehler1.f = 0     ;init
    For z2 = 1 To #a  ; adjustment 1
      Fehler1 = Fehler1 + OFehler(z2) * Gewichte2(z1, z2)  ;sum of adjustment
    Next
    VFehler(z1) = VNeurons(z1) * (1.0 - VNeurons(z1)) * Fehler1    ;fill covered adjustment array
  Next
  
  ProcedureReturn MaxFehler
EndProcedure

Procedure Gewichte_anpassen()  
  ;second layer adjustment
  For z1 = 0 To #a    ;foreach output neuron
    For z2 = 0 To #v    ;foreach covered neuron
      Gewichte2(z2, z1) = Gewichte2(z2,z1) + (#LK * OFehler(z1)) * VNeurons(z2)    ;delta rule
    Next
  Next
  
  ;first weight layer adjustment
  For z1 = 0 To #v    ;foreach covered neuron
    For z2 = 0 To #n * #n    ;foreach input neuron
      Gewichte1(z2, z1) = Gewichte1(z2, z1) + (#LK * VFehler(z1)) * Inputs(z2)     ;delta rule
    Next
  Next
EndProcedure


;- LEARN
Init_Gewichte()   


For z = 1 To #LD
  Generiere_Input()    
  Berechne_Outputs()   
  Berechne_Fehler()    
  
    
  Gewichte_anpassen() 
Next

OpenConsole()
PrintN("Training finished!")
PrintN("")

;- TEST
richtige = 0
OpenWindow(0,200,200,200,200,#PB_Window_SystemMenu,"")
For z = 1 To #TD
  Generiere_Input()
  
  StartDrawing(WindowOutput())
    DrawImage(UseImage(Image),0,0,32,32)
  StopDrawing()
  
  Berechne_Outputs()
  If (SollOutputs(1) > 0.8 And Outputs(1) > 0.8) Or (SollOutputs(1) < 0.2 And Outputs(1) < 0.2)  ;is it in tolerance of 0.2?
    richtige + 1
  EndIf
Next

PrintN("Test:")
PrintN("Rights of " + Str(#TD) + ": " + Str(richtige))
PrintN("In percentage: " + StrF(richtige / #TD * 100.0))

Input()

Coming soon: Fractals and Attractors

remi_meier · Post by **remi_meier** » Sat Sep 24, 2005 9:37 pm

Love the beauty of mathematics!

Mostly, you can use your keyboard do animate them!

Attractor: Peter de Jong

Code: Select all

sx=GetSystemMetrics_(0) 
sy=GetSystemMetrics_(1) 
sd=32 

InitSprite() 
InitKeyboard() 

iterationen=300000 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
a.f=-2.24  ;-2 
b.f=0.43 ;-2 
c.f=-0.65  ;-1.2 
d.f=-2.43  ;2 
factor.f=250 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 


If OpenScreen(sx,sy,sd,"Random") 
  Repeat 
    x0.f=1 
    y0.f=1 
    x1.f=1 
    y1.f=1 
    
    ExamineKeyboard() 
    
    FlipBuffers() 
    ClearScreen(0,0,0) 
    
    If KeyboardPushed(#PB_Key_Right) 
      a.f+0.1 
    ElseIf KeyboardPushed(#PB_Key_Left) 
      a.f-0.1 
    ElseIf KeyboardPushed(#PB_Key_Insert) 
      b.f+0.1 
    ElseIf KeyboardPushed(#PB_Key_Delete) 
      b.f-0.1 
    ElseIf KeyboardPushed(#PB_Key_PageUp) 
      c.f+0.1 
    ElseIf KeyboardPushed(#PB_Key_PageDown) 
      c.f-0.1 
    ElseIf KeyboardPushed(#PB_Key_RightShift) 
      factor.f+2 
    ElseIf KeyboardPushed(#PB_Key_RightControl) 
      factor.f-2 
    ElseIf KeyboardPushed(#PB_Key_Up)     ;UNBEDINGT 
      d.f+0.1 
    ElseIf KeyboardPushed(#PB_Key_Down) 
      d.f-0.1 
    EndIf 
    
    StartDrawing(ScreenOutput()) 
    For i=0 To iterationen 
      x1=Sin(a*y0)-Cos(b*x0) 
      y1=Sin(c*x0)-Cos(d*y0) 
      x0=x1 
      y0=y1 
      
      xp=Round(x0*factor+sx/2,1) 
      yp=Round(y0*factor+sy/2,1) 
      If (i>100) And xp>0 And xp<sx And yp>0 And yp<sy 
        Plot(xp,yp,Round(Sqr(sx*sx+sy*sy)/Sqr((xp-sx/2)*(xp-sx/2)+(sy/2-yp)*(sy/2-yp))*16777216,1)) 
      EndIf 
    Next 
    StopDrawing() 
    
    Delay(5) 
  Until KeyboardReleased(1) 
  CloseScreen() 
  
Else 
  MessageRequester("Error","Can't open screen",0) 
EndIf

Attractor: Wallpaper

Code: Select all

sx=GetSystemMetrics_(0)
sy=GetSystemMetrics_(1)
sd=32

InitSprite()
InitKeyboard()

iterationen=100000
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; unbedingt probieren!!!
factor.f=1
a.f=1; a.f=-1000; a.f=-1; a.f=10.4; 
b.f=4; b.f=0.1; b.f=-2; b.f=1; 
c.f=60; c.f=-10; c.f=-3; c.f=0; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Procedure sign(l)
  If l>0
    ProcedureReturn 1
  ElseIf l<0
    ProcedureReturn-1
  Else 
    ProcedureReturn 0
  EndIf
  
EndProcedure

If OpenScreen(sx,sy,sd,"Random") 
  Repeat
    x0.f=0
    y0.f=0
    x1.f=0
    y1.f=0
    
    ExamineKeyboard()
    
    FlipBuffers()
    ClearScreen(0,0,0)
    
    If KeyboardReleased(#PB_Key_Right)
      a.f+0.000001
    ElseIf KeyboardReleased(#PB_Key_Left)
      a.f-0.000001
    ElseIf KeyboardReleased(#PB_Key_Up)
      b.f+0.000001
    ElseIf KeyboardReleased(#PB_Key_Down)
      b.f-0.000001
    ElseIf KeyboardReleased(#PB_Key_PageUp)
      c.f+0.0001
    ElseIf KeyboardReleased(#PB_Key_PageDown)
      c.f-0.0001
    ElseIf KeyboardPushed(#PB_Key_RightShift)
      factor.f+0.1
    ElseIf KeyboardPushed(#PB_Key_RightControl)
      factor.f-0.1
    EndIf
    
    StartDrawing(ScreenOutput())
    For i=0 To iterationen
      x1=y0-sign(x0)*Pow(Abs(b*x0-c),1/2)
      y1=a-x0
      x0=x1
      y0=y1
      
      xp=x0*factor+Round(sx/2,1)
      yp=y0*factor+Round(sy/2,1)
      If (i>100) And xp>0 And xp<sx And yp>0 And yp<sy
        Plot(xp,yp,Round(i/iterationen*16777000,1)) 
      EndIf
      
    Next
    StopDrawing()
    
    Delay(5)
  Until KeyboardReleased(1)
  CloseScreen() 
  
Else
  MessageRequester("Error","Can't open screen",0)
EndIf

Fractal and Recursion

Code: Select all

InitSprite()
InitKeyboard()
OpenScreen(1280,1024,32,"Hallo")


x=500
y=500
r=200


Procedure star(x,y,r)
  If r>0
    star(x-r,y+r,Round(r/2,0))
    star(x+r,y+r,Round(r/2,0))
    star(x-r,y-r,Round(r/2,0))
    star(x+r,y-r,Round(r/2,0))
    
    Box(x-Int(r/2),y-Int(r/2),r,r,RGB(255,0,0))   ;bei Pascal box(x,y,r)
  EndIf
EndProcedure


StartDrawing(ScreenOutput())
  star(x,y,r)
StopDrawing()
FlipBuffers()

Repeat
  ExamineKeyboard()
Until KeyboardPushed(1)

Little excursion: Gauss solve
Solve linear equation systems:

Code: Select all

Procedure GaussSolve(*Matrix.l, N.l)
  Protected N, h.f, i, j, k, *Matrix, *Matrix0
  N = N - 1
  
  Dim __matrix.f(N, N - 1)
  *Matrix0 = @__matrix()
  __matrix() = *Matrix
  
  
  For i = 0 To N - 1
    h = __matrix(i, i)
    If h = 0
      __matrix() = *Matrix0
      Dim __matrix.f(0, 0)
      ProcedureReturn 0
    EndIf
    For j = 0 To N
      __matrix(j, i) = __matrix(j, i) / h
    Next
    For j = 0 To N - 1
      If i <> j
        h = __matrix(i, j)
        For k = 0  To N
          __matrix(k, j) = __matrix(k, j) - __matrix(k, i) * h
        Next
      EndIf
    Next
  Next
  
  __matrix() = *Matrix0
  Dim __matrix.f(0, 0)
  ProcedureReturn 1
EndProcedure

#x = 3
#y = 2
Dim Matrix.f(#x - 1, #y - 1)

For y = 0 To #y - 1
  For x = 0 To #x - 1
    Read Matrix(x, y)
  Next
Next

GaussSolve(@Matrix(), #x)

line.s
For y = 0 To #y - 1
  For x = 0 To #x - 1
    line + StrF(Matrix(x, y)) + " "
  Next
  Debug line
  line = ""
Next




DataSection
matrix:
Data.f 7, 2, 3
Data.f 8, 3, 9
EndDataSection

Program: Iterative Function Systems: IFS

Code: Select all

sx = 500 ;GetSystemMetrics_(0) 
sy = 700 ;GetSystemMetrics_(1) 

 
InitSprite() 
InitKeyboard() 




Dim Sets.f(3, 5)
param.s = ProgramParameter()
If param = ""
  For x = 0 To 3
    For y = 0 To 5
      Sets(x, y) = (Random(1000) / 1000.0) - 0.5  ;(Random(2000) / 1000) - 1.0
    Next
  Next
  
Else ;Lade übergebenes File in Parameterliste Sets()
  OpenPreferences(param)
  For x = 0 To 3
    For y = 0 To 5
      Sets(x, y) = ReadPreferenceFloat(Str(x)+Str(y), 0.0)
    Next
  Next
  ClosePreferences()
EndIf


 
Global a.f, b.f, c.f, d.f, e.f, f.f
DefType.f x0,y0,z0,x1,y1,z1 

 
Global n, zoom
n  = 20000 
x0 = 0.1 
y0 = 0 
zoom = 100
 

Procedure EVENTS()
  Select WindowEvent()
    Case 0
      Delay(10)
      
    Case #PB_Event_Gadget
      gadgetid = EventGadgetID()
      If gadgetid <= 6
        Sets(0, gadgetid - 1)  = (GetGadgetState(gadgetid) - 1000.0) / 500.0
      ElseIf gadgetid <= 12
        Sets(1, gadgetid - 7)  = (GetGadgetState(gadgetid) - 1000.0) / 500.0
      ElseIf gadgetid <= 18
        Sets(1, gadgetid - 13) = (GetGadgetState(gadgetid) - 1000.0) / 500.0
      ElseIf gadgetid <= 24
        Sets(1, gadgetid - 19) = (GetGadgetState(gadgetid) - 1000.0) / 500.0
      ElseIf gadgetid = 25 ;Iterationen
        n = GetGadgetState(gadgetid) * 10
      ElseIf gadgetid = 26 ;zoom
        zoom = GetGadgetState(gadgetid)
      ElseIf gadgetid = 27 ;{speichern
        Name.s = "IFS-FILE"
        While FileSize(Name + ".ifs") <> -1
          Name = "Neu " + Name
        Wend
        Name + ".ifs"
        
        CreatePreferences(Name)
        For x = 0 To 3
          For y = 0 To 5
            WritePreferenceFloat(Str(x)+Str(y), Sets(x, y))
          Next
        Next
        ClosePreferences();}
      EndIf
      
    Case #PB_Event_CloseWindow
      End
  EndSelect
EndProcedure


If OpenWindow(0, 200, 700, 800, 700, #PB_Window_ScreenCentered|#PB_Window_SystemMenu, "IFS-Generator") And OpenWindowedScreen(WindowID(),200,0,sx,sy,1,0,0) 
  If CreateGadgetList(WindowID()) ;{
    TrackBarGadget(1, 5, 5, 190,15, 0, 2000)
    SetGadgetState(1, Sets(0, 0) * 1000 + 1000)
    TrackBarGadget(2, 5,25, 190,15, 0, 2000)
    SetGadgetState(2, Sets(0, 1) * 1000 + 1000)
    TrackBarGadget(3, 5,45, 190,15, 0, 2000)
    SetGadgetState(3, Sets(0, 2) * 1000 + 1000)
    TrackBarGadget(4, 5,65, 190,15, 0, 2000)
    SetGadgetState(4, Sets(0, 3) * 1000 + 1000)
    TrackBarGadget(5, 5,85, 190,15, 0, 2000)
    SetGadgetState(5, Sets(0, 4) * 1000 + 1000)
    TrackBarGadget(6, 5,105, 190,15, 0, 2000)
    SetGadgetState(6, Sets(0, 5) * 1000 + 1000)
    
    TrackBarGadget(7, 5,125, 190,15, 0, 2000)
    SetGadgetState(7, Sets(1, 0) * 1000 + 1000)
    TrackBarGadget(8, 5,145, 190,15, 0, 2000)
    SetGadgetState(8, Sets(1, 1) * 1000 + 1000)
    TrackBarGadget(9, 5,165, 190,15, 0, 2000)
    SetGadgetState(9, Sets(1, 2) * 1000 + 1000)
    TrackBarGadget(10, 5,185, 190,15, 0, 2000)
    SetGadgetState(10, Sets(1, 3) * 1000 + 1000)
    TrackBarGadget(11, 5,205, 190,15, 0, 2000)
    SetGadgetState(11, Sets(1, 4) * 1000 + 1000)
    TrackBarGadget(12, 5,225, 190,15, 0, 2000)
    SetGadgetState(12, Sets(1, 5) * 1000 + 1000)
    
    TrackBarGadget(13, 5,245, 190,15, 0, 2000)
    SetGadgetState(13, Sets(2, 0) * 1000 + 1000)
    TrackBarGadget(14, 5,265, 190,15, 0, 2000)
    SetGadgetState(14, Sets(2, 1) * 1000 + 1000)
    TrackBarGadget(15, 5,285, 190,15, 0, 2000)
    SetGadgetState(15, Sets(2, 2) * 1000 + 1000)
    TrackBarGadget(16, 5,305, 190,15, 0, 2000)
    SetGadgetState(16, Sets(2, 3) * 1000 + 1000)
    TrackBarGadget(17, 5,325, 190,15, 0, 2000)
    SetGadgetState(17, Sets(2, 4) * 1000 + 1000)
    TrackBarGadget(18, 5,345, 190,15, 0, 2000)
    SetGadgetState(18, Sets(2, 5) * 1000 + 1000)
    
    TrackBarGadget(19, 5,365, 190,15, 0, 2000)
    SetGadgetState(19, Sets(3, 0) * 1000 + 1000)
    TrackBarGadget(20, 5,385, 190,15, 0, 2000)
    SetGadgetState(20, Sets(3, 1) * 1000 + 1000)
    TrackBarGadget(21, 5,405, 190,15, 0, 2000)
    SetGadgetState(21, Sets(3, 2) * 1000 + 1000)
    TrackBarGadget(22, 5,425, 190,15, 0, 2000)
    SetGadgetState(22, Sets(3, 3) * 1000 + 1000)
    TrackBarGadget(23, 5,445, 190,15, 0, 2000)
    SetGadgetState(23, Sets(3, 4) * 1000 + 1000)
    TrackBarGadget(24, 5,465, 190,15, 0, 2000)
    SetGadgetState(24, Sets(3, 5) * 1000 + 1000)
    
    TrackBarGadget(25, 5,500, 190,15, 0, 10000)
    SetGadgetState(25, n / 10)
    
    TrackBarGadget(26, 5,530, 190,15, 0, 1000)
    SetGadgetState(26, zoom) 
    
    ButtonGadget(27, 5, 560, 60, 25, "Speichern")
    ;}
  EndIf
  
  Repeat 
    ExamineKeyboard() 
    
    ClearScreen(0,0,0) 
    
    StartDrawing(ScreenOutput())
    For i=0 To n-1 
      x1 = a * x0 + b * y0 + c 
      y1 = d * x0 + e * y0 + f 
      
      k = Random(3)
      a.f = Sets(k, 0)
      b.f = Sets(k, 1)
      c.f = Sets(k, 2)
      d.f = Sets(k, 3)
      e.f = Sets(k, 4)
      f.f = Sets(k, 5)
      
      x0 = x1
      y0 = y1 
      
      xp = x0 * zoom + Round(sx/2,1) 
      yp = y0 * zoom + Round(sy/2,1) 
      If (i > 100) And xp > 0 And xp < sx And yp > 0 And yp < sy 
        color = i / 100 * 16777000
        FrontColor(Red(color), Green(color), Blue(color))
        Plot(xp, yp);, color) ;-- here
      EndIf 
    Next 
    StopDrawing() 
    
    If KeyboardPushed(#PB_Key_F1) 
      sp = GrabSprite(#PB_Any, 0, 0, sx, sy)
      SaveSprite(sp, "Screenshot.bmp")
      FreeSprite(sp)
    EndIf 
    
    EVENTS()
    FlipBuffers() 
  Until KeyboardPushed(1) 
  CloseScreen() 
  
Else 
  MessageRequester("Error","Can't open screen",0) 
EndIf

The beautiful Lorenz Attractor

Code: Select all

sx=GetSystemMetrics_(0) 
sy=GetSystemMetrics_(1) 
sd=32 

InitSprite() 
InitKeyboard() 

DefType.f  x0,y0,z0,x1,y1,z1 
h.f=0.01 
a.f=10.0 
b.f=28.0 
c.f=8.0/3.0 

n=10000

If OpenScreen(sx,sy,sd,"Lorenz") 
  
  Repeat 
    ExamineKeyboard() 
    FlipBuffers() 
    ClearScreen(0,0,0) 
    
    
    
    x0=0.1 
    y0=0 
    z0=0 
    
    If KeyboardPushed(#PB_Key_Right)
      a.f+0.1
    ElseIf KeyboardPushed(#PB_Key_Left)
      a.f-0.1
    ElseIf KeyboardPushed(#PB_Key_Up)
      b.f+0.1
    ElseIf KeyboardPushed(#PB_Key_Down)
      b.f-0.1
    ElseIf KeyboardPushed(#PB_Key_PageUp)
      c.f+0.1
    ElseIf KeyboardPushed(#PB_Key_PageDown)
      c.f-0.1
    ElseIf KeyboardPushed(#PB_Key_RightShift)
      h.f+0.0001
    ElseIf KeyboardPushed(#PB_Key_RightControl)
      h.f-0.0001
    EndIf
    
    
    StartDrawing(ScreenOutput()) 
    For i=0 To n-1 
      x1=x0+h*a*(y0-x0) 
      y1 = y0 + h * (x0 * (b - z0) - y0); 
      z1 = z0 + h * (x0 * y0 - c * z0) 
      x0 = x1 
      y0 = y1 
      z0 = z1 
      
      xp=x0*10+Round(sx/2,1)
      yp=y0*10+Round(sy/2,1)
      
      
      If (i>100) And xp>0 And xp<sx And yp>0 And yp<sy
         Plot(xp,yp,i/100*16777000) 
      EndIf 
    Next 
    StopDrawing() 
    
    Delay(5) 
  Until KeyboardPushed(1) 
  
  CloseScreen() 
  
Else 
  MessageRequester("Error","Can't open screen",0) 
EndIf

Rossler-Attractor

Code: Select all

sx=GetSystemMetrics_(0)
sy=GetSystemMetrics_(1)
sd=32

InitSprite()
InitKeyboard()


Structure xyz
  x.f
  y.f
  z.f
EndStructure
h.f=0.015;0.05
a.f=0.2
b.f=0.2
c.f=5.7
plast.xyz
plast\x=0.0001;0.1
plast\y=0.0001;0
plast\z=0.0001;0
p.xyz
n=350000


If OpenScreen(sx,sy,sd,"Random")
  
  
  Repeat
    ExamineKeyboard()
    
    FlipBuffers()
    ClearScreen(0,0,0)
    
    
    
    StartDrawing(ScreenOutput())
    For i=0 To n-1
      p\x=plast\x+h*(-plast\y-plast\z)
      p\y=plast\y+h*(plast\x+a*plast\y)
      p\z=plast\z+h*(b+plast\z*(plast\x-c))
      If i>100
        Plot(p\x*10+Round(sx/2,1),p\y*10+Round(sy/2,1),RGB(Round(i/n*255,0),Round(i/n*255,0),1))
      EndIf
      plast\x=p\x
      plast\y=p\y
      plast\z=p\z
    Next
    StopDrawing()
    
    If KeyboardReleased(#PB_Key_Space)
      Repeat
        Delay(5)
        ExamineKeyboard()
        If KeyboardPushed(1):End:EndIf
      Until KeyboardReleased(#PB_Key_Space)
    EndIf
    
    
    Delay(5)
  Until KeyboardPushed(1)
  CloseScreen() 
  
Else
  MessageRequester("Error","Can't open screen",0)
EndIf

Binary Sierpinski?

Code: Select all

OpenWindow(0, 200,200, 500,500, #PB_Window_SystemMenu, "")

Img = CreateImage(#PB_Any, 500, 500)

Repeat
  
  StartDrawing(ImageOutput())
    For x = 0 To 500 
      For y = 0 To 500 
        If x & y <> 0  
          Plot(x,y, $FF)
        EndIf 
      Next y 
    Next x
  StopDrawing()
  StartDrawing(WindowOutput())
    DrawImage(UseImage(Img), 0,0)
  StopDrawing()
  
  Event = WaitWindowEvent()
  If Event = 0
    Delay(1)
  EndIf
Until Event = #PB_Event_CloseWindow

IFS: Tree

Code: Select all

sx=GetSystemMetrics_(0) 
sy=GetSystemMetrics_(1) 
sd=32 
 
InitSprite() 
InitKeyboard() 
 
DefType.f a, b, c, d, e, f


Dim Sets.f(4, 5)
Sets(0, 0) = 0.1950
Sets(0, 1) = -0.4880
Sets(0, 2) = 0.3440
Sets(0, 3) = 0.4430
Sets(0, 4) = 0.4431
Sets(0, 5) = 0.2452

Sets(1, 0) = 0.4620
Sets(1, 1) = 0.4140
Sets(1, 2) = -0.2520
Sets(1, 3) = 0.3610
Sets(1, 4) = 0.2511
Sets(1, 5) = 0.5692

Sets(2, 0) = -0.6370
Sets(2, 1) = 0.0000
Sets(2, 2) = 0.0000
Sets(2, 3) = 0.5010
Sets(2, 4) = 0.8562
Sets(2, 5) = 0.2512

Sets(3, 0) = -0.0350
Sets(3, 1) = 0.0700
Sets(3, 2) = -0.4690
Sets(3, 3) = 0.0220
Sets(3, 4) = 0.4884
Sets(3, 5) = 0.5069

Sets(4, 0) = -0.0580
Sets(4, 1) = -0.0700
Sets(4, 2) = 0.4530
Sets(4, 3) = -0.1110
Sets(4, 4) = 0.5976
Sets(4, 5) = 0.0969


 

DefType.f x0,y0,z0,x1,y1,z1 
a.f = Sets(0, 0)
b.f = Sets(0, 1)
c.f = Sets(0, 2)
d.f = Sets(0, 3)
e.f = Sets(0, 4)
f.f = Sets(0, 5)
 
 
n  = 40000 
x0 = 0.1 
y0 = 0 
 
 
If OpenScreen(sx,sy,sd,"Lorenz") 
  Repeat 
    ExamineKeyboard() 
    
    FlipBuffers() 
    ClearScreen(0,0,0) 
    
    StartDrawing(ScreenOutput()) 
    For i=0 To n-1 
      ; xn+1 = a xn + b yn + e
      ; yn+1 = c xn + d yn + f
      x1     = a*x0 + b*y0 + e
      y1     = c*x0 + d*y0 + f
      
      k = Random(4)
      a.f = Sets(k, 0)
      b.f = Sets(k, 1)
      c.f = Sets(k, 2)
      d.f = Sets(k, 3)
      e.f = Sets(k, 4)
      f.f = Sets(k, 5)
      
      x0 = x1
      y0 = y1 
      
      xp = Round(sx/2,1) - x0 * 400
      yp = Round(sy/2,1) - y0 * 400
      If (i>100) And xp>0 And xp<sx And yp>0 And yp<sy 
        Plot(xp,yp,i/100*16777000) 
      EndIf 
    Next 
    StopDrawing() 
    
    If KeyboardPushed(#PB_Key_F1) 
      sp = GrabSprite(#PB_Any, 0, 0, sx, sy)
      SaveSprite(sp, "Screenshot.bmp")
      FreeSprite(sp)
    EndIf 
    
    Delay(5) 
  Until KeyboardPushed(1) 
  CloseScreen() 
  
Else 
  MessageRequester("Error","Can't open screen",0) 
EndIf 
 
MessageRequester("Seed", Str(seed))

IFS: Tree 2

Code: Select all

sx=GetSystemMetrics_(0) 
sy=GetSystemMetrics_(1) 
sd=32 
 
InitSprite() 
InitKeyboard() 
 
DefType.f a, b, c, d, e, f


Dim Sets.f(6, 5)
Sets(0, 0) = 0.0500
Sets(0, 1) = 0.0000
Sets(0, 2) = 0.0000
Sets(0, 3) = 0.4000
Sets(0, 4) = -0.0600
Sets(0, 5) = -0.4700

Sets(1, 0) = -0.0500
Sets(1, 1) = 0.0000
Sets(1, 2) = 0.0000
Sets(1, 3) = -0.4000
Sets(1, 4) = -0.0600
Sets(1, 5) = -0.4700

Sets(2, 0) = 0.0300
Sets(2, 1) = -0.1400
Sets(2, 2) = 0.0000
Sets(2, 3) = 0.2600
Sets(2, 4) = -0.1600
Sets(2, 5) = -0.0100

Sets(3, 0) = -0.0300
Sets(3, 1) = 0.1400
Sets(3, 2) = 0.0000
Sets(3, 3) = -0.2600
Sets(3, 4) = -0.1600
Sets(3, 5) = -0.0100

Sets(4, 0) = 0.1900
Sets(4, 1) = 0.0700
Sets(4, 2) = -0.1000
Sets(4, 3) = 0.1500
Sets(4, 4) = -0.2000
Sets(4, 5) = 0.2800

Sets(5, 0) = -0.3300 
Sets(5, 1) = -0.3400 
Sets(5, 2) = -0.3300
Sets(5, 3) = 0.3400 
Sets(5, 4) = -0.5400 
Sets(5, 5) = 0.3900

Sets(6, 0) = 0.5600
Sets(6, 1) = 0.4400
Sets(6, 2) = -0.3700
Sets(6, 3) = 0.5100
Sets(6, 4) = 0.3000
Sets(6, 5) = 0.1500


 

DefType.f x0,y0,z0,x1,y1,z1 
a.f = Sets(0, 0)
b.f = Sets(0, 1)
c.f = Sets(0, 2)
d.f = Sets(0, 3)
e.f = Sets(0, 4)
f.f = Sets(0, 5)
 
 
n  = 60000 
x0 = 0.1 
y0 = 0 
 
 
If OpenScreen(sx,sy,sd,"Lorenz") 
  Repeat 
    ExamineKeyboard() 
    
    FlipBuffers() 
    ClearScreen(0,0,0) 
    
    StartDrawing(ScreenOutput()) 
    For i=0 To n-1 
      ; xn+1 = a xn + b yn + e
      ; yn+1 = c xn + d yn + f
      x1     = a*x0 + b*y0 + e
      y1     = c*x0 + d*y0 + f
      
      k = Random(6)
      a.f = Sets(k, 0)
      b.f = Sets(k, 1)
      c.f = Sets(k, 2)
      d.f = Sets(k, 3)
      e.f = Sets(k, 4)
      f.f = Sets(k, 5)
      
      x0 = x1
      y0 = y1 
      
      xp = Round(sx/2,1) - x0 * 400
      yp = Round(sy/2,1) - y0 * 400
      If (i > 100) And xp > 0 And xp < sx And yp > 0 And yp < sy 
        Plot(xp, yp, i / 100 * 16777000) 
      EndIf 
    Next 
    StopDrawing() 
    
    If KeyboardPushed(#PB_Key_F1) 
      sp = GrabSprite(#PB_Any, 0, 0, sx, sy)
      SaveSprite(sp, "Screenshot.bmp")
      FreeSprite(sp)
    EndIf 
    
    Delay(5) 
  Until KeyboardPushed(1) 
  CloseScreen() 
  
Else 
  MessageRequester("Error","Can't open screen",0) 
EndIf

Dijkstra: Shortest Way

Code: Select all

#N = 4  ; count of nodes

#M = 99999  ; = infinite
; distance between nodes
Dim Boegen.l(#N - 1, #N - 1)

Restore distanzen
For y = 0 To #N - 1
  For x = 0 To #N - 1
    Read Boegen(x, y)
  Next
Next


; Start and Stop nodes
StartK = 0
StopK  = 3

; distance to start node
Dim Distanz(#N - 1)

; previous node
Dim Vorgaenger(#N - 1)

; nodes where we know the shortest way
Dim Markierte(#N - 1)
For z = 0 To #N - 1
  Markierte(z) = #False
Next

; start node already visited
Markierte(StartK) = #True
; distance to itself = 0
Distanz(StartK) = 0
; previous node itself
Vorgaenger(StartK) = StartK

; foreach node distance and previous node
For z = 0 To #N - 1
  ; without start node
  If z <> StartK
    Distanz(z)    = Boegen(StartK, z)
    Vorgaenger(z) = StartK
  EndIf
Next


; while we didn't find the shortest way to the stop node
While Markierte(StopK) = #False
  ; find shortest distance in not marked nodes
  MinK = -1
  MinD = #M
  For z = 0 To #N - 1
    ; if not marked
    If Markierte(z) = #False
      ; if shorter distance
      If Distanz(z) < MinD
        MinK = z
        MinD = Distanz(z)
      EndIf
    EndIf
  Next
  
  
  ; if there isn't a shortest way (Distanz = infinite) -> no way!
  If MinD = #M
    Debug "There isn't a connection between StartK and StopK"
    Break
    
  ElseIf MinK = StopK
    ; found the shortest way
    Debug "Found"
    Break
    
  Else
    ; mark it, shortest way found
    Markierte(MinK) = #True
  EndIf
  
  
  ; foreach not marked node: check if there is a shorter way via MinK
  For z = 0 To #N - 1
    If Markierte(z) = #False
      ; If this way is shorter
      If Distanz(MinK) + Boegen(MinK, z) < Distanz(z)
        ; calc new distances
        Distanz(z)    = Distanz(MinK) + Boegen(MinK, z)
        ; add the way via 'z'
        Vorgaenger(z) = MinK
      EndIf
    EndIf
  Next
  
Wend


If MinK = StopK
  ; backtrace the way of StopK
  s.s  = Str(StopK)
  z    = MinK
  While Vorgaenger(z) <> StartK
    s = Str(Vorgaenger(z)) + ", " + s
    z = Vorgaenger(z)
  Wend
  s = Str(Vorgaenger(z)) + ", " + s
  
  Debug s
  Debug "Distance: " + Str(Distanz(StopK))
EndIf




DataSection
distanzen:
Data.l 0, 2, 4, #M
Data.l 2, 0, 1, 7
Data.l 4, 1, 0, 3
Data.l #M,7, 3, 0
EndDataSection

I think that was it

greetz
Remi

Hroudtwolf · Post by **Hroudtwolf** » Sat Sep 24, 2005 9:47 pm

LOL

Thanks for sharing.
This will take a long time to test it all.

traumatic · Post by **traumatic** » Sat Sep 24, 2005 10:01 pm

Phew!

Thanks for sharing!

Droopy · Post by **Droopy** » Sat Sep 24, 2005 10:06 pm

Very productive

dracflamloc · Post by **dracflamloc** » Sat Sep 24, 2005 10:12 pm

Perhaps a zipped file would be easier =P

va!n · Post by **va!n** » Sat Sep 24, 2005 10:33 pm

@remi_meier:
respect! very nice work! thanks for sharing! keep on your work!

Post by **Andre** » Sat Sep 24, 2005 10:37 pm

Thanks Remi, and of course the codes will be included in the new CodeArchive!

okasvi · Post by **okasvi** » Sat Sep 24, 2005 11:38 pm

nice collection of code

thought little more description on each would have been good

sry for my english

techjunkie · Post by **techjunkie** » Sun Sep 25, 2005 1:28 am

Wow!

Great work! Thanks!!

MrMat · Post by **MrMat** » Sun Sep 25, 2005 2:30 am

Whoa, nice list!

remi_meier · Post by **remi_meier** » Sun Sep 25, 2005 12:36 pm

Thanks.

> Very productive
This is the work since the last release of the code archive 18. January 2004,
so enough time

> Perhaps a zipped file would be easier =P

Yes, but not as pompous as this. No, now you can find them with
the search function of the forum. And not everyone knows about the
Code archive (incredible!).

> Thanks Remi, and of course the codes will be included in the new CodeArchive!

> thought little more description on each would have been good
I'm a little bit too lazy... But don't hesitate to ask some questions!

Have fun!
greetz
Remi

PureBasic Forums - English

Some of my codes

Some of my codes

Re: Some of my codes