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

For other topics related to the FreeBASIC project or its community.
D.J.Peters
Posts: 7455
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.

Joshy

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 29, 2018 19:41, edited 2 times in total.
JohnK
Posts: 279
Joined: Sep 01, 2005 5:20
Location: Earth, usually
Contact:

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.
jdebord
Posts: 509
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

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 !
badidea
Posts: 1002
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?
h4tt3n
Posts: 670
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!
BasicCoder2
Posts: 3308
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.
viewtopic.php?f=2&t=13530&hilit=escapi
His other contribution I have on hand is multiput.bi because it is so fast.
viewtopic.php?f=7&t=24079&hilit=multiput.bi
Although he has also given FreeBASIC programmers access to many things you need the talent and time to learn and use them all.
.
dafhi
Posts: 1220
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)
#EndIf

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
 private:
  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)
 private:
  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
 private:
  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
  ret=((_
  (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
#EndMacro



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
 private:
  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
          Alpha256(*px,*px,p->col,alpha_max)
      elseif salpha<=coneSq then
          alph=(cone_h-sqr(salpha))*alpha_max
          Alpha256(*px,*px,p->col,alph)
      endif:  dx+=slope
    next: dy+=slope
  next
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)
  #EndMacro
  var j=(lb+ub)\2, i=lb
  sw(j,ub)
  sw(j,lb)
  sw(lb,ub)
  j=ub
  while i<j
    while a(j)dot b2 a(lb)dot: j-=1: wend
    i+=1
    while a(i)dot b1 a(lb)dot: i+=1: wend
    if j<=i then i=j: exit while 'Sep 21
    sw(i,j)
    j-=1
  Wend
  'sw(lb,i) - Sep 20
  sw(lb,j)
  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
#endmacro

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

set_sort(tPar,_sort,down,.p.z)


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
constructor.ParticleClique
  throw_vel.rand
  throw_acc.rand
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.rand
      .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
  next

  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
  do
 
    gt=timer:  gdt=gt-tp:  tp=gt
   
    dim as long i
    while i<=ub
      a(i).frame
      if a(i).fuel < 0 then swap a(i), a(ub): ub-=1: i-=1
      i+=1
    Wend
   
    if ub>0 then _sort a(), ub

    screenlock
      cls
      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.o.col=.col
                dot.draw x,y
              endif
            endif
          endif
         
          if phase=0 then
            if .age > 0.9 then
              if rnd < .003 then
                v.rand
                v *= ps(.idx_specie).vel*.5
              endif
              if rnd < .07 then
                .acc += type(0, 0, -1500) + v/2
              endif
            endif
          endif
        end with
      Next
    screenunlock
   
    sleep 1
   
    dim as string kstr = inkey
    if kstr = chr(27) then exit do
   
    if gt-t0 > tDemoTime then exit do
   
  Loop

  sleep 1100
end sub

Main
Last edited by dafhi on Oct 02, 2017 18:43, edited 2 times in total.
srvaldez
Posts: 1672
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
D.J.Peters
Posts: 7455
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()

Joshy
St_W
Posts: 1404
Joined: Feb 11, 2009 14:24
Location: Austria
Contact:

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 4 guests