A list of my FreeBASIC activities of the past 10 years.

For other topics related to the FreeBASIC project or its community.
Posts: 7219
Joined: May 28, 2005 3:28

A list of my FreeBASIC activities of the past 10 years.

Postby D.J.Peters » Oct 16, 2015 9:20

All my download links never changed and are active since ten years
but in near future my ISP must change the alice-net.de domain (it's owned by O2)

So I created a list with all links for my private use but I think it can be usefull for others to.


A list of my FreeBASIC activities of the past 10 years.

Libraries and include files:

Tips and Tricks (source codes):

Last edited by D.J.Peters on Oct 17, 2015 23:48, edited 1 time in total.
Posts: 279
Joined: Sep 01, 2005 5:20
Location: Earth, usually

Re: A list of my FreeBASIC activities of the past 10 years.

Postby JohnK » Oct 17, 2015 5:09

Big thanks DJ !!
I always look forward to your library update. I wished I had more time to play but I am excited about VCL.
Keep up the great work, as always.
Posts: 507
Joined: May 27, 2005 6:20
Location: Limoges, France

Re: A list of my FreeBASIC activities of the past 10 years.

Postby jdebord » Oct 17, 2015 7:53

Very useful collection of links ! Thank you very much !
Posts: 610
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: A list of my FreeBASIC activities of the past 10 years.

Postby badidea » Oct 17, 2015 20:37

Amazing. Where do you find the time and motivation for all this work?
Posts: 659
Joined: Oct 22, 2005 21:12
Location: Denmark

Re: A list of my FreeBASIC activities of the past 10 years.

Postby h4tt3n » Nov 14, 2015 18:15

Second the above!
Posts: 3035
Joined: Jan 01, 2009 7:03

Re: A list of my FreeBASIC activities of the past 10 years.

Postby BasicCoder2 » Nov 14, 2015 19:33

It was Joshy's escapi.bi that pulled me into using FreeBASIC as it enabled me to capture webcam images which could be displayed with FreeBASICs inbuilt graphics library.
His other contribution I have on hand is multiput.bi because it is so fast.
Although he has also given FreeBASIC programmers access to many things you need the talent and time to learn and use them all.
Posts: 976
Joined: Jun 04, 2005 9:51

Re: A list of my FreeBASIC activities of the past 10 years.

Postby dafhi » Oct 02, 2017 3:14

Code: Select all

dim shared as double    gt, gdt ''global time & delta

#ifndef pi
const   TwoPi = 8*atn(1)
const   Pi = 4*atn(1)
const   piBy2 = 2*atn(1)

function clamp(in as single, hi as single=1, lo as single=0) as single
  if in < lo then return lo
  if in > hi then return hi
  return in
End Function

type float as double

type v3
  as float          x,y,z
  declare sub       norm
  declare property  len as float
  declare property  len(in as float)
  declare function  dot(r as v3) as float
  declare function  perp(in as float=1) as v3
  declare function  cross(in as v3, slen as float=1) as v3
  declare sub       rand
  declare property  n as v3
end type
property v3.len as float: return sqr(x*x+y*y+z*z): end property
function v3.dot(r as v3) as float: return x*r.x+y*r.y+z*r.z: end function
sub v3.norm:  dim as float s=1/sqr(x*x+y*y+z*z): x*=s:y*=s:z*=s: end sub
property v3.len(in as float)
  var s = in/sqr(x*x+y*y+z*z): x*=s: y*=s: z*=s
End Property
property v3.n as v3
  var s = x*x+y*y+z*z
  if s<>0 then s=1/sqr(s)
  return type(x*s,y*s,z*s)
End Property
function v3.perp(in as float) as v3
  if y=0 then return type(0, in, 0)
  var s=z*z+x*x: if s=0 then return type(in,0,0)
  s=in/sqr(s):  return type(-z*s, 0, x*s)
End function
function v3.cross(r as v3, slen as float) as v3
  var xx=y*r.z - z*r.y
  var yy=z*r.x - x*r.z
  var zz=x*r.y - y*r.x
  var s = xx*xx+yy*yy+zz*zz
  if s=0 then return type(0,0,0)
  s=slen/sqr(s):  return type(xx*s,yy*s,zz*s)
End function
operator -(r as v3) as v3: return type(-r.x, -r.y, -r.z): end operator
operator -(l as v3,r as v3) as v3: return type(l.x-r.x,l.y-r.y,l.z-r.z): end operator
operator +(l as v3,r as v3) as v3: return type(l.x+r.x, l.y+r.y, l.z+r.z): end operator
operator /(l as v3,r as float) as v3: dim as float s = 1/r: return type(l.x*s,l.y*s,l.z*s): end operator
operator *(l as v3,r as float) as v3: return type(l.x*r,l.y*r,l.z*r): end operator
operator *(l as float, r as v3) as v3: return type(l*r.x,l*r.y,l*r.z): end operator
operator *(l as v3,r as v3) as v3: return type(l.x*r.x,l.y*r.y,l.z*r.z): end operator
sub v3.rand
  y=2*(rnd-.5):  var r=sqr(1-y*y)
  z=rnd*twopi: x=r*cos(z): z=r*sin(z)
End Sub

function hsv(h as single, s as single, v as single) as v3
  h -= 6*int(h/6)
  dim as single x = clamp(2 - h - 2*(h-3)*(h>3))
  dim as single y = clamp(h +     2*(h-2)*(h>2))
  dim as single z = clamp(h - 2 + 2*(h-4)*(h>4))
  dim as single ptr  lo=@x, mi=@y, hi=@z
  if *lo > *mi then swap lo, mi
  if *mi > *hi then swap mi, hi
  if *lo > *hi then swap lo, hi
  *lo = v * (*hi - s * (*hi - *lo))
  *mi = v * (*hi - s * (*hi - *mi))
  *hi *= v
  return type(x,y,z)
End function

type tPar           '2017 Sep 20
  as long           col
  as v3             p, vel, acc
  as single         k, fuel, lifetime, fps
  declare sub       ini(k as single = .5, lifetime as single=3, fps as single=67)
  declare property  age as single
  declare sub       new_kinetics
  declare sub       frame
  declare sub       backup
  declare sub       restore
  as single         ifps
  as long           idx_specie
  as single         ik, iok
  as single         j, kj, sv_j, sv_kj
End Type
property tPar.age as single: return lifetime-fuel
End Property
sub tPar.backup: sv_j=j: sv_kj=kj
End Sub
sub tPar.restore: j=sv_j: kj=sv_kj
End Sub
sub tPar.ini(_k as single, _lifetime as single, _fps as single):  fps = _fps
  ifps = 1/fps:  k=_k:  lifetime=_lifetime
  new_kinetics:  j=0: kj=1
  :  fuel=lifetime-rnd*ifps
End Sub
sub tPar.new_kinetics:  ik = 1/(1-k):  iok = 1/(1-1/k)
End Sub
sub tPar.frame:  var i=lifetime-fuel
  var ki = k^i, v = k*(kj-ki)
  p += ik*( vel*v + acc*( (i-j)*k + v*iok ) )
  j=i: kj=ki
  fuel -= gdt
End sub

type StatRand 'randomize units within group constraints
  as single           avg, vari, v
  declare operator    cast as single
  declare sub         rand
  declare sub         def(avg as single=.5, rad as single=.25, vari_avg as single=1, var_rad as single=1)
  declare             constructor(avg as single=.5, rad as single=.25, vari_avg as single=1, var_rad as single=1)
  as single           avg_avg, avg_vari, var_avg, var_vari
end type
constructor.StatRand(avg as single, rad as single, vari_avg as single, var_rad as single)
  def avg, rad, vari_avg, var_rad
end constructor
operator StatRand.cast as single
  v=avg+vari*(rnd-0.5): return v
end operator
sub StatRand.rand
  avg  = avg_avg + avg_vari*(rnd-0.5)
  vari = var_avg + var_vari*(rnd-0.5)
end sub
sub StatRand.def(avg as single, rad as single, _vari_avg as single, vari_rad as single)
  avg_avg = avg:  avg_vari=rad*2
  var_avg = _vari_avg
  var_vari = vari_rad*2
  rand: v=avg+vari*(rnd-0.5)
end sub

type imagevars '2017 Aug 31 - by dafhi
  '1. quick reference for ScreenInfo & ImageInfo
  '2. encapsulate standard metrics
  '3. convenient additional vars, subs and functions
  as integer            w,h, bpp,bypp,pitch, rate
  as string             driver_name
  as any ptr            im
  as any ptr            pixels    'same address
  as ulong ptr          p32       '
  as single             midx,midy
  as integer            pitchBy, wm = -1, hm = -1, ub = -1, is_screen
  declare sub           screen_init(w as integer=0, h as integer=0, bpp as integer=32, npages as integer=1, flags as integer=0)
  declare sub           create(w as integer=0, h as integer=0, col as ulong=&HFF000000)
  declare sub           get_info(im as any ptr=0)
  declare               destructor
  declare sub           release
  declare sub           destroy
  as any ptr            hRelease
end type
Destructor.imagevars:  release
End Destructor
sub imagevars.release                             '2016 Aug 30
  w=0: h=0: bpp=0: bypp=0: im=0: pixels=0
  If ImageInfo(hRelease) = 0 Then ImageDestroy hRelease:  hRelease = 0
End Sub
sub imagevars.get_info(im as any ptr)
  if im=0 then
    ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name:  pixels=screenptr
    is_screen = -1: im=0
  elseif Imageinfo(im)=0 then
    ImageInfo im, w, h, bypp, pitch, pixels:  bpp = bypp * 8
    this.im = im:  is_screen = 0
  endif: hRelease = im:  p32=pixels
  wm=w-1:  midx=w/2:  pitchBy=pitch/bypp '' crashes if \ and bypp = 0
  hm=h-1:  midy=h/2:  ub = h*pitchBy - 1
end sub
sub imagevars.screen_init(w as integer, h as integer, bpp as integer, npages as integer, flags as integer)
  release '2017 July 3
  if w=0 or h=0 then get_info: w=this.w: h=this.h
  screenres w,h,bpp,npages,flags: pixels = screenptr
  get_info:  if npages > 1 then screenset 0,1
end sub
sub imagevars.create(_w as integer, _h as integer, col as ulong) '2017 sep 1
  if _w<1 or _h<1 then exit sub
  release:  get_info imagecreate(_w,_h,col)
End Sub

#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
  (fore And &Hff00ff) * a256 + _
  (back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
  (fore And &H00ff00) * a256 + _
  (back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8

type dotvars
  as ulong            col=-1
  as single           rad=1,slope=1
End Type

type AaDot
  as dotvars          o
  as dotvars ptr      p
  declare sub         render_target(byref buf as imagevars ptr)
  declare sub         draw(x as single=0, y as single=0)
  declare constructor
  as single           dy,dxLeft,salpha,cone_h,coneSq,sq,salpha0
  as long             x0,y0,x1,y1,alph,alpha_max
  as imagevars ptr    pim
end type
constructor.AaDot: p=@o
end constructor
sub AaDot.render_target(byref buf as imagevars ptr)
  pim = buf
end sub
sub AaDot.draw(x as single, y as single)

  salpha0=(p->col shr 24)/255:  alpha_max=salpha0*256
  var slope = p->slope
  'slope = 1 .. 1 pixel aa edge
  'slope = 2 .. 1/2 pixel (sharp)
  'slope = 1/p->rad .. max blur
  'slope < 1/p->rad .. rendering artifact
  'sq=1/p->rad                   '' clamp prevents artifact
  'slope=iif(slope<sq,sq,slope)  ''
  cone_h=slope*(p->rad+.5)     'pre-inverted aadot imagined as cone \/
  coneSq=cone_h*cone_h    'avoid sqr() at blit corners
  sq=(cone_h-1)*(cone_h-1)'avoid sqr() in dot center at max brightness
  dim as long x0=(x-p->rad):  if x0<0 then x0=0
  dim as long y0=(y-p->rad):  if y0<0 then y0=0
  dim as long x1=(x+p->rad):  if x1>pim->wm then x1=pim->wm
  dim as long y1=(y+p->rad):  if y1>pim->hm then y1=pim->hm
  dy=(y0-y)*slope: dxLeft=(x0-x)*slope
  for py as long ptr = @pim->p32[ y0*pim->pitchBy ] to @pim->p32[ y1*pim->pitchBy ] step pim->pitchBy
    dim as single dx=dxleft, dySq=dy*dy
    for px as ulong ptr = @py[x0] to @py[x1]
      salpha = dx*dx+dySq
      if salpha<sq then
      elseif salpha<=coneSq then
      endif:  dx+=slope
    next: dy+=slope
end sub

#macro set_sort(datatype,fname,b1,b2,dot) 'my new quicksort, dodicats macro
sub fname(a() as datatype, ub as long=-1, lb as long=0) 'lb=0, ub=-1
  '2017 Sep 21
  #macro sw(x,y)
    if a(x)dot b2 a(y)dot then swap a(x), a(y)
  var j=(lb+ub)\2, i=lb
  while i<j
    while a(j)dot b2 a(lb)dot: j-=1: wend
    while a(i)dot b1 a(lb)dot: i+=1: wend
    if j<=i then i=j: exit while 'Sep 21
  'sw(lb,i) - Sep 20
  i-=1: if lb<i then fname a(), i,lb 'lb,i
  j+=1: if j<ub then fname a(), ub,j 'j,ub
End Sub

#define up <,>
#define down >,<


type ParticleClique
  as statrand k=type(.07,.01,0,0)
  as statrand vel=type(650,700,0,0)
  as statrand acc=type(10, 10, 0,0)
  as statrand lifetime=type(9, 7, 1.3, 1.2)
  as statrand fps=type(35, 34)
  as statrand hue=type(0,3,.5,.5)
  as statrand sat=type(.65,.25,.05,.05)
  as statrand emi_win=type(3, 3)
  as v3       throw_vel
  as v3       throw_acc
  declare constructor
End Type
end constructor

function round(in as single, places as ubyte = 2) as string
  dim as integer mul = 10 ^ places
  return str(csng(int(in * mul + .5) / mul))
End Function

const                   _UB = 15000
dim shared as tPar      a(_UB)

const                   w = 640, wm=w-1, midx = wm/2
const                   h = 480, hm=h-1, midy = hm/2

sub Main

  var c_ps = 50
  dim as ParticleClique ps(c_ps-1)
  var ub = _UB
  for i as long = 0 to ub
    var si_ps = rnd*c_ps
    var p_ps = @ps(int(si_ps))
    with a(i)
      .ini p_ps->k, p_ps->lifetime, p_ps->fps 'motion blur
      .vel += type(0,.5,90) + p_ps->throw_vel*4'3.5
      .vel *= p_ps->vel * .7
      .acc += p_ps->throw_acc*12
      .acc *= p_ps->acc * 1
      var c = hsv(6*int(si_ps)/c_ps, rnd, 1)
      .col = rgb(int(c.x*255.999), int(c.y*255.999), int(c.z*255.999))
      .idx_specie = int(si_ps)
    end with

  dim as imagevars buf:  buf.screen_init w,h
  dim as aadot dot:  dot.render_target @buf
  dim as v3 v
  var tp=timer, t0 = tp, tDemoTime = 7, phase = 0
    gt=timer:  gdt=gt-tp:  tp=gt
    dim as long i
    while i<=ub
      if a(i).fuel < 0 then swap a(i), a(ub): ub-=1: i-=1
    if ub>0 then _sort a(), ub

      draw string (buf.midx-60, buf.midy-20), "Happy birthday"
      draw string (buf.midx-55, buf.midy-0), "D.J. Peters !"
      for i as long = 0 to ub
        with a(i)
          if .p.z > -2500 then
            var s=2500/(.p.z+2500)
            var x = midx+.p.x*s
            if x >= 0 and x < w then
              var y = hm-midy-.p.y*s
              if y >= 0 and y < h then
                dot.o.rad = 1.0*s
                dot.o.slope = 1.4/dot.o.rad
                dot.draw x,y
          if phase=0 then
            if .age > 0.9 then
              if rnd < .003 then
                v *= ps(.idx_specie).vel*.5
              if rnd < .07 then
                .acc += type(0, 0, -1500) + v/2
        end with
    sleep 1
    dim as string kstr = inkey
    if kstr = chr(27) then exit do
    if gt-t0 > tDemoTime then exit do

  sleep 1100
end sub

Last edited by dafhi on Oct 02, 2017 18:43, edited 2 times in total.
Posts: 1462
Joined: Sep 25, 2005 21:54

Re: A list of my FreeBASIC activities of the past 10 years.

Postby srvaldez » Oct 02, 2017 3:25

hello dafhi
didn't know it was D.J.Peters BD
Posts: 7219
Joined: May 28, 2005 3:28

Re: A list of my FreeBASIC activities of the past 10 years.

Postby D.J.Peters » Oct 02, 2017 17:01

@dafhi thank you :-)

compile with -exx and you will see:
Aborting due to runtime error 6 (out of bounds array access) at line 361 of tmp.bas::MAIN()

Posts: 1246
Joined: Feb 11, 2009 14:24
Location: Austria

Re: A list of my FreeBASIC activities of the past 10 years.

Postby St_W » Nov 17, 2017 17:19

You probably didn't notice, but most (if not all) of your work doesn't contain a license. That makes your work practically useless as it is illegal to use it without you explicitly granting a license. If you are not aware yet, why it is so important to choose a license, see https://blog.codinghorror.com/pick-a-li ... y-license/
Also see https://choosealicense.com/no-license/ for the implications of not providing a license and https://choosealicense.com/ as a help for choosing an appropriate license.

I want to kindly request to think about it and adding a license to your work. Of course if you choose to grant no license that's also fine. You just shouldn't leave potential users of your projects unaware of this.

Return to “Community Discussion”

Who is online

Users browsing this forum: No registered users and 2 guests