It is currently Fri Mar 22, 2019 9:57 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 22 posts ]  Go to page 1, 2  Next
Author Message
 Post subject: Some of my codes
PostPosted: Sat Sep 24, 2005 8:45 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
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 :lol:


Vector-Class
For calculating with vectors.
Code:
; 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:
;- 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:
; 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 :lol:

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Last edited by remi_meier on Sat Jan 21, 2006 3:13 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 8:56 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
The show must go on!

Simple Turtle Graphics
A class for drawings like fractals.
Code:
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:
; 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:
#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:
#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:
#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:
; 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:
#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...

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Last edited by remi_meier on Sat Jan 21, 2006 3:18 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 9:04 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
Can't post them all, but the most important ones...

Reversed Polish Notation
How to translate 3+4*5 into 3 4 5 * +
Code:
; 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:
;/ 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:
; 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:
; 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 :wink:

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Last edited by remi_meier on Sat Jan 21, 2006 3:31 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 9:20 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
So... Ever heard of Neural Networks?
Here they are (not all :lol: )

Very simple Example
Just recognize an 'A'
Sry for the German comments...
Code:
;"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:
;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:
;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:
;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:
;/ 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

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Last edited by remi_meier on Sat Jan 21, 2006 5:02 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 9:37 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
Love the beauty of mathematics!

Mostly, you can use your keyboard do animate them!

Attractor: Peter de Jong
Code:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
#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 :wink:

greetz
Remi :)

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Last edited by remi_meier on Sat Jan 21, 2006 5:10 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 9:47 pm 
Offline
Addict
Addict
User avatar

Joined: Sat Feb 12, 2005 3:35 am
Posts: 803
Location: Germany(Hessen)
LOL :D

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

_________________
German blog about IT and programming
German PB forums


Top
 Profile  
Reply with quote  
 Post subject: Re: Some of my codes
PostPosted: Sat Sep 24, 2005 10:01 pm 
Offline
PureBasic Expert
PureBasic Expert
User avatar

Joined: Sun Apr 27, 2003 4:41 pm
Posts: 1661
Location: Germany
Phew! :shock:

Thanks for sharing!

_________________
Good programmers don't comment their code. It was hard to write, should be hard to read.


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 10:06 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Sep 16, 2004 9:50 pm
Posts: 658
Location: France
Very productive 8)

_________________
DroopyLib/PBFastLib/HMod


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 10:12 pm 
Offline
Addict
Addict
User avatar

Joined: Mon Sep 20, 2004 3:52 pm
Posts: 1648
Perhaps a zipped file would be easier =P


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 10:33 pm 
Offline
Addict
Addict
User avatar

Joined: Wed Apr 20, 2005 12:48 pm
Posts: 1104
@remi_meier:
respect! very nice work! thanks for sharing! keep on your work! :wink:

_________________
va!n aka Thorsten

Intel i7-980X Extreme Edition, 12 GB DDR3, Radeon 5870 2GB, Windows7 x64,


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 10:37 pm 
Offline
PureBasic Team
PureBasic Team
User avatar

Joined: Fri Apr 25, 2003 6:14 pm
Posts: 1662
Location: Germany (Saxony, Deutscheinsiedel)
Thanks Remi, and of course the codes will be included in the new CodeArchive! :wink:

_________________
Bye,
...André
(PureBasicTeam::Docs & Support - PureArea.net | Order:: PureBasic | PureVisionXP)


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sat Sep 24, 2005 11:38 pm 
Offline
Enthusiast
Enthusiast

Joined: Wed Apr 27, 2005 9:41 pm
Posts: 150
Location: Finland
nice collection of code :shock:

thought little more description on each would have been good :D

sry for my english :|


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sun Sep 25, 2005 1:28 am 
Offline
Addict
Addict
User avatar

Joined: Wed Oct 15, 2003 12:40 am
Posts: 1126
Location: Sweden
Wow! :shock: Great work! Thanks!! :D

_________________
Image
(\__/)
(='.'=) This is Bunny. Copy and paste Bunny into your
(")_(") signature to help him gain world domination.


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sun Sep 25, 2005 2:30 am 
Offline
Enthusiast
Enthusiast

Joined: Sun Sep 05, 2004 6:27 am
Posts: 761
Location: England
Whoa, nice list! :)

_________________
Mat


Top
 Profile  
Reply with quote  
 Post subject:
PostPosted: Sun Sep 25, 2005 12:36 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Dec 20, 2003 6:19 pm
Posts: 468
Location: Switzerland
Thanks.

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

> Perhaps a zipped file would be easier =P
:lol: 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!
:wink:

> 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

_________________
Athlon64 3700+, 1024MB Ram, Radeon X1600


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 22 posts ]  Go to page 1, 2  Next

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 8 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye