Artistic license

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Artistic license

Postby sean_vn » Feb 16, 2015 10:06

Artistic license. Or can I sell you some bad poetry?

Code: Select all

#define PROBELIMIT 1000
#define UNKNOWN -1

type KNOW
   mask as ulongint
   table(any) as ulongint
   bvalues(any) as ubyte
 
   hkey as ulongint
   hindex as ulongint
   hprobe as ulongint
 
   declare constructor(size as ulongint)
   
   declare function getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   declare sub setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
 
    declare function find() as longint
   declare sub resethash()
   declare sub nexthash(x as ubyte)
 
end type

'size must be a power of 2 (eg. 2,4,8,16,...)
constructor KNOW(size as ulongint)
   this.mask=size-1
   if (size and mask)<>0 then error(1)
   redim this.table(mask) as ulongint
   redim this.bvalues(mask) as ubyte
end constructor

function KNOW.find() as longint
   dim as ulongint idx=hindex,probe=hprobe or 1,key=iif(hkey=0,1,hkey)
   for i as ulong =1 to PROBELIMIT
       dim as ulongint j=idx and mask
       dim as ulongint t=table(j)
      if t=0 or t=key then return j
      idx+=probe
    next
    return UNKNOWN
end function

'returns UNKNOWN if it can't find anything suitable
function KNOW.getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   resethash()
   nexthash(x[index])
   dim as longint idx=find()
   if idx=UNKNOWN then return UNKNOWN
   if table(idx)=0 then return UNKNOWN
   dim as ubyte res=bvalues(idx)
   while index<>0
      index-=1
      nexthash(x[index])
      idx=find()
      if idx=UNKNOWN then exit while
      if table(idx)=0 then exit while   
      res=bvalues(idx)
   wend
   return res
end function

sub KNOW.setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
   dim as long res=getByteAfterIndex(x,index)
   if res=byteAfter then return
   dim as longint idx=find()
   if idx=UNKNOWN then return
   if table(idx)=0 then
      table(idx)=iif(hkey=0,1,hkey)
      bvalues(idx)=byteAfter
   end if
end sub

sub KNOW.resethash()
   hkey=0
   hindex=0
   hprobe=0
end sub

sub KNOW.nexthash(x as ubyte)
   hkey+=x+&he8e92631f2614fe1ULL
   hindex+=x+&h18373fe1619628abULL
   hprobe+=x+&h57eba727a2c23d17ULL
   hkey*=2862933555777941757ull
   hindex*=3202034522624059733ull
   hprobe*=3935559000370003845ull
   hkey xor=hkey shr 31
   hindex xor=hindex shr 31
   hprobe xor=hprobe shr 31
end sub


dim as string s="I am a bronze maiden and I stand on Midas' tomb, For as long as water flows and tall trees bloom, Remaining right here on his much-lamented tomb, I will announce to passersby that Midas is buried in this place."
s+=s
dim as KNOW k=KNOW(512)
for i as long=0 to len(s)-2
   k.setByteAfterIndex(strptr(s),i,asc(s,i+2))
   print  chr(asc(s,i+2));
next
print
print
 s="b"
for i as long=0 to 200
     dim as long b=k.getByteAfterIndex(strptr(s),i)
     if b=UNKNOWN then b=32
   print chr(b);
   s=s+chr(b)
next

   
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 17, 2015 0:33

This is based on an idea I had 22 years ago. It is an if except if list going backwards in a sequence (or time if you like). The original version used linked lists and was limited to like 256Kb memory. It still could remember words and small sections of books. Using a hash table is much more memory efficent and these days 10,000 times the memory is common.

It works this way (by way of an example):
If the value at index is 70 then the next byte is 66
If the value at index is 56 then the next byte is 32 except if the value at index-1 is 44 then the next byte is 55

This information is stored in the hash table. You can go back in the sequence however much you need to clarify what the next byte should be.
Last edited by sean_vn on Feb 17, 2015 0:39, edited 1 time in total.
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 17, 2015 0:36

Just on a technical note I had to use this in the constructor to redim the arrays. If I left it out they were not redimed which may be a compiler problem.
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 17, 2015 11:42

Code: Select all


#define PROBELIMIT 1000
#define UNKNOWN -1

type KNOW
   mask as ulongint
   table(any) as ulongint
   bvalues(any) as ubyte
 
   hkey as ulongint
   hindex as ulongint
   hprobe as ulongint
   
   idx as ulongint
   key as ulongint
   badSlot as long
 
   declare constructor(size as ulongint)
   
   declare function getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   declare sub setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
 
    declare sub find()
   declare sub resethash()
   declare sub nexthash(x as ubyte)
 
end type

'size must be a power of 2 (eg. 2,4,8,16,...)
constructor KNOW(size as ulongint)
   this.mask=size-1
   if (size and mask)<>0 then error(1)
   redim this.table(mask) as ulongint
   redim this.bvalues(mask) as ubyte
end constructor

sub KNOW.find()
   dim as ulongint probe=hprobe or 1
   key=iif(hkey=0,1,hkey)
   idx=hindex
   badSlot=0 'false
   for i as ulong=1 to PROBELIMIT
       idx and=mask
       dim as ulongint t=table(idx)
      if t=0 or t=key then return
      idx+=probe
    next
    badSlot=-1 'true
end sub

'returns UNKNOWN if it can't find anything suitable
function KNOW.getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   resethash()
   nexthash(x[index])
   find()
   if badSlot then return UNKNOWN
   if table(idx)=0 then return UNKNOWN
   dim as ubyte res=bvalues(idx)
   while index<>0
      index-=1
      nexthash(x[index])
      find()
      if badSlot then exit while
      if table(idx)=0 then exit while   
      res=bvalues(idx)
   wend
   return res
end function

sub KNOW.setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
   dim as long res=getByteAfterIndex(x,index)
   if res=byteAfter then return
   if badslot then return
   if table(idx)=0 then
      table(idx)=key
      bvalues(idx)=byteAfter
   end if
end sub

sub KNOW.resethash()
   hkey=0
   hindex=0
   hprobe=0
end sub

sub KNOW.nexthash(x as ubyte)
   hkey+=x+&he8e92631f2614fe1ULL
   hindex+=x+&h18373fe1619628abULL
   hprobe+=x+&h57eba727a2c23d17ULL
   hkey*=2862933555777941757ull
   hindex*=3202034522624059733ull
   hprobe*=3935559000370003845ull
   hkey xor=hkey shr 31
   hindex xor=hindex shr 31
   hprobe xor=hprobe shr 31
end sub


dim as string s="I am a bronze maiden and I stand on Midas' tomb, For as long as water flows and tall trees bloom, Remaining right here on his much-lamented tomb, I will announce to passersby that Midas is buried in this place."
s+=s
s+=s
dim as KNOW k=KNOW(512)
for i as long=0 to len(s)-2
   k.setByteAfterIndex(strptr(s),i,asc(s,i+2))
   print  chr(asc(s,i+2));
next
print
print
s="hello Midas'"
for i as long=len(s)-1 to 400
     dim as long b=k.getByteAfterIndex(strptr(s),i)
     if b=UNKNOWN then b=32
   print chr(b);
   s+=chr(b)
next
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 17, 2015 14:29

I ran The Odyssey through the code and starting with "cake " I got this work of art:

Venus in tender drops. Antinous saw, and said:

"Hence to yon court, without the palace with an equal sway.
Be it my care, by loans, or martial toils,
To throng my empty forms of men inhabit there,
Impassive semblance, images of air!
Naught else are all that shined on earth before:
Ajax and great Achilles! blend
With dear Patroclus, thy departed friend:
In the same urn a separate space contains
Thy next beloved, Antilochus' remains.
Now all the sons of warlike Greece sur
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Re: Artistic license

Postby 1000101 » Feb 17, 2015 19:08

I get no output from the original code beyond a slightly mangled input. Basically it just repeats the entire body of the input stream with the first couple characters chopped off and truncated at the end.

Code: Select all

 tomb, For as long as water flows and tall trees bloom, Remaining right here on
his much-lamented tomb, I will announce to passersby that Midas is buried in thi
s place.I am a bronze maiden and I stand on Midas' tomb, For as long as water fl
ows and tall trees bloom, Remaining right here on his much-lamented tomb, I will
 announce to passersby that Midas is buried in this place.I am a bronz


I have no changed the code at all. I'm not sure what this program is intended to do, but it doesn't? At least, this output makes no sense to me given the context of the alleged output from using "The Odyssey" and "cake."
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 22, 2015 9:37

That's the same output as I got for such a short input string. If anyone was interested they could experiment a little (with longer strings for example.) Up to you!
I would say it is doing a form of reinforcement learning. The reason for looking at this thing again is that it seems like a good sort of memory system for reinforcement learning generally. I am also interested in playing to the twin strengths of modern computers - high speed and really, I think, vast amounts of memory. I feel if you genuinely exploit those two things together you could do very well.
The code is set up in a slightly complicated way to deal with byte streams generally, rather than just strings.
You train it by giving it the next byte in a sequence. The sequence is gotten by working backwards from a given index in a ubyte buffer.
Later you can predict the next byte in a sequence. It is perfectly normal to get recurring output patterns if you try predicting very far ahead from one simple input sequence. It isn't quite the Oracle of Delphi.
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Feb 22, 2015 10:17

So maybe if you wanted to you could get a book in text form from http://www.archive.org and do something like this:

Code: Select all

#include "file.bi"
#define fn "a.txt"
dim as uInteger bread,flen=filelen(fn)
Dim ff As UByte
ff = FreeFile
Open fn For Binary As #ff
dim as ubyte ptr s=callocate(flen)
get #ff,,*s,flen,bread
Close #ff

dim as KNOW k=KNOW(65536*64)
for i as long=10 to flen-2
   k.setByteAfterIndex(s,i,s[i+1])
next

dim as string t="Some starting string here "
for i as long=len(t)-1 to 500
     dim as long b=k.getByteAfterIndex(strptr(t),i)
     if b=UNKNOWN then b=32
   t+=chr(b)
next
print t
   
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Mar 02, 2015 6:29

I've been learning a little more about how this idea works out. I tried it on image data where you attempt to predict a pixel byte from the values of nearby pixels. It works out well but it does show that for large data sets you may have to do multiple passes to fully resolve the system.
You could call it a reverse telescoping hash table? Whatever.
I want to think about what happens if you feed in a few bits of information into a hash (table) from a data set, rather than a large number of bits at a time. Obviously you are reducting the number of potential states you can visit at each step. Can you gain from this? So you are kind of getting into the area of information theory.

kimage.bas

Code: Select all

#include "know3.bas"
#define SEQLEN 250
#define SPREAD 1000
#define SEED 12345678

dim shared as long patternX(SEQLEN-1)
dim shared as long patternY(SEQLEN-1)
dim shared as ubyte seq(3*SEQLEN)      ' by 3 colors plus 1
dim shared as KNOW ksystem

sub init(size as ulongint)
   dim as double mean=SPREAD*0.5f
   randomize(SEED)
   for i as ulong=0 to SEQLEN-1
      dim as double totalX,totalY
        for j as ulong=1 to SPREAD
         totalX+=rnd()
         totalY+=rnd()
      next
      patternX(i)=totalX-mean         '2D Gaussian distribution
      patternY(i)=totalY-mean
      if patternX(i)=0 and patternY(i)=0 then 'offset never (0,0) since that    
         patternX(i)=iif(rnd()>.5,1,-1)      'is the point to predict
         patternY(i)=iif(rnd()>.5,1,-1)
      end if
   next
   ksystem=KNOW(size)
end sub

sub eatimage(image as any ptr)
   dim as integer srcW,srcH
   imageinfo(image,srcW,srcH)
   for y as long=0 to srcH-1
      for x as long=0 to srcW-1
         dim as ulong spos,clr
         for i as long=0 to SEQLEN-1
         dim as long x1=x+patternX(i),y1=y+patternY(i)
             if x1<0 or x1>=srcW or y1<0 or y1>=srcH then
                clr=0
            else
               clr=point(x1,y1,image)
            end if
            seq(spos)=clr
            spos+=1
            clr shr=8
            seq(spos)=clr
            spos+=1
            clr shr=8
            seq(spos)=clr
            spos+=1
         next
         clr=point(x,y,image)
         seq(spos)=0
         ksystem.setByteAfterIndex(@seq(0),spos,clr and 255)
         seq(spos)=1
         ksystem.setByteAfterIndex(@seq(0),spos,(clr shr 8) and 255)
         seq(spos)=2
         ksystem.setByteAfterIndex(@seq(0),spos,(clr shr 16) and 255)
      next
   next
end sub

sub predictimage(predictedimage as any ptr,srcimage as any ptr)
   dim as integer pW,pH
   imageInfo(predictedimage,pW,pH)
   for y as long=0 to pH-1
      for x as long=0 to pW-1
         dim as ulong spos,clr
         for i as long=0 to SEQLEN-1
             dim as long x1=x+patternX(i),y1=y+patternY(i)
             if x1<0 or x1>=pW or y1<0 or y1>=pH then
                clr=0
            else
               clr=point(x1,y1,srcimage)
            end if
            seq(spos)=clr
            spos+=1
            clr shr=8
            seq(spos)=clr
            spos+=1
            clr shr=8
            seq(spos)=clr
            spos+=1
         next
         seq(spos)=2
         clr=ksystem.getByteAfterIndex(@seq(0),spos)
         clr shl=8
         seq(spos)=1
         clr or=ksystem.getByteAfterIndex(@seq(0),spos)
         clr shl=8
         seq(spos)=0
         clr or=ksystem.getByteAfterIndex(@seq(0),spos)
         pset predictedimage,(x,y),clr
      next
   next
end sub

'from FB documentation
Function bmp_load( ByRef filename As Const String ) As Any Ptr
    Dim As Integer filenum, bmpwidth, bmpheight
    Dim As Any Ptr img
    filenum = FreeFile()
    If Open( filename For Binary Access Read As #filenum ) <> 0 Then Return 0
    Get #filenum, 19, bmpwidth
    Get #filenum, 23, bmpheight
    Close #filenum
    img = ImageCreate( bmpwidth, Abs(bmpheight) )
    If img = 0 Then Return 0
    If BLoad( filename, img ) <> 0 Then ImageDestroy( img ): Return 0
    Return img
End Function

' returns 0 on success
function eatBMP(filename as string) as long
   dim as any ptr img=bmp_load(filename)
   if img=0 then return -1
   eatimage(img)
   imagedestroy(img)
   return 0
end function

screenres 1000,480,32
init(65536*32)
dim as any ptr img1=bmp_load("a.bmp")
dim as any ptr img3
put (20,20),img1

eatimage(img1) ' retraining a few times can help remove any unresolved conflicts
'eatimage(img1)
'eatimage(img1)

cls
print "Count "&ksystem.count(),"out of "&(1+ksystem.mask)
'ksystem.save("ks.ks")
'ksystem.load("ks.ks")
dim as integer w,h

imageinfo(img1,w,h)
img3=imagecreate(w,h)

'circle img1,(100,100),15,,,,,F
put (10,20),img1,PSET
predictimage(img3,img1)
put (520,20),img3,PSET

imagedestroy(img1)
imagedestroy(img3)
sleep

know3.bas

Code: Select all


#define PROBELIMIT 1000
#define UNKNOWN -1

type KNOW
   mask as ulongint
   table(any) as ulongint
   bvalues(any) as ubyte
 
   hkey as ulongint
   hindex as ulongint
   hprobe as ulongint
   
   idx as ulongint
   key as ulongint
   wrongSlot as long
 
    declare constructor()
   declare constructor(size as ulongint)
   
   declare function getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   declare sub setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
 
    declare sub find()
   declare sub resethash()
   declare sub nexthash(x as ubyte)
   declare function save(filename as string) as long
   declare function load(filename as string) as long
   declare function checkmemory() as long
   declare function count() as ulongint
 
end type

constructor KNOW()
end constructor

'size must be a power of 2 (eg. 2,4,8,16,...)
constructor KNOW(size as ulongint)
   mask=size-1
   if (size and mask)<>0 then error(1)
   redim this.table(mask) as ulongint
   redim this.bvalues(mask) as ubyte
end constructor

sub KNOW.find()
   dim as ulongint probe=hprobe or 1
   key=iif(hkey=0,1,hkey)
   idx=hindex
   wrongSlot=0 'false
   for i as ulong=1 to PROBELIMIT
       idx and=mask
       dim as ulongint t=table(idx)
      if t=0 or t=key then return
      idx+=probe
    next
    wrongSlot=-1 'true
end sub

'returns UNKNOWN if it can't find anything suitable
function KNOW.getByteAfterIndex(x as ubyte ptr,index as ulongint) as long
   resethash()
   nexthash(x[index])
   find()
   if wrongSlot then return UNKNOWN
   if table(idx)=0 then return UNKNOWN
   dim as ubyte res=bvalues(idx)
   while index<>0
      index-=1
      nexthash(x[index])
      find()
      if wrongSlot then exit while
      if table(idx)=0 then exit while   
      res=bvalues(idx)
   wend
   return res
end function

sub KNOW.setByteAfterIndex(x as ubyte ptr,index as ulongint,byteAfter as ubyte)
   dim as long res=getByteAfterIndex(x,index)
   if res=byteAfter then return
   if wrongSlot then return
   if table(idx)=0 then
      table(idx)=key
      bvalues(idx)=byteAfter
   end if
end sub

sub KNOW.resethash()
   hkey=0
   hindex=0
   hprobe=0
end sub

sub KNOW.nexthash(x as ubyte)
   hkey+=x+&he8e92631f2614fe1ULL
   hindex+=x+&h18373fe1619628abULL
   hprobe+=x+&h57eba727a2c23d17ULL
   hkey*=2862933555777941757ull
   hindex*=3202034522624059733ull
   hprobe*=3935559000370003845ull
   hkey xor=hkey shr 31
   hindex xor=hindex shr 31
   hprobe xor=hprobe shr 31
end sub

'returns 0 on success
function KNOW.save(filename as string) as long
   dim as long e,f
   f=freefile()
   open filename for binary access write as #f
   e or=put( #f,,mask)
    e or=put( #f,,table())
    e or=put( #f,,bvalues())
   close #f
   return e
end function

'returns 0 on success
function KNOW.load(filename as string) as long
   dim as integer e,f
   f=freefile()
   open filename for binary access read as #f
   e or=get( #f,,mask)
   redim this.table(mask) as ulongint
   e or=err() 'memory error
   redim this.bvalues(mask) as ubyte
   e or=err()
   e or=get( #f,,table())
   e or=get( #f,,bvalues())
   close #f
   return e
end function

'check if memory allocation went well, returns 0 if no error.
function KNOW.checkmemory() as long
   if ubound(table)<>mask or ubound(bvalues)<>mask then return -1
   return 0
end function

function KNOW.count() as ulongint
    dim as ulongint ct
   for i as ulongint=0 to mask
      if table(i)<>0 then ct+=1
   next
   return ct
end function

sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Mar 06, 2015 1:39

This is what I am experimenting with today. The idea is to spread out and dilute the information in the data sequence and feed it into the hash table at less than one 1 bit at time (from an information theory perspective). This should give better generalization. You end up with a multiresolution hash table based function approximator. I was looking through the literature and the nearest things I could find were the ideas of Albus from the 1970's and some work by John Moody. Byte magazine June 1979 has a very long winded article by Albus. It is worth reading anyway, I think (http://www.archive.org). It seems to me it was more informed by real biology than a lot of current AI. Modern AI research is still very much Alchemy, though lots of people are getting paid lots of money for their spells and potions.
It cost $625 for 64 KB of RAM in 1979 which must of impeded research quite a bit. It could be a good idea to revisit some of these older ideas given how much hardware has improved

krystal.bas

Code: Select all

#define PROBELIMIT 1000
#define UNKNOWN -1
#define SKIP1 &h28ba3d7eaccac1ULL
#define SKIP2 &h527d7a7c7d73bfULL
#define RNDSTART &hc3638fd667ad61ULL

type Krystal
   mask as ulongint
   dilutionmask as ulong
   table(any) as ulongint
   bvalues(any) as ubyte
   dilute(any) as single
 
   hkey as ulongint
   hindex as ulongint
   hprobe as ulongint
   rand as ulongint
   
   idx as ulongint
   key as ulongint
   wrongSlot as long
 
    declare constructor()
   declare constructor(size as ulongint,dilution as ulong)
   
   declare function getByteForSequence(seq() as single) as long
   declare sub setByteForSequence(seq() as single,byteFor as ubyte)
 
    declare sub find()
   declare sub resethash()
   declare sub nexthash(index as ulong)
   declare sub mix(v() as single)
   declare sub wht(v() as single)
   declare sub signflip(v() as single)
   declare sub permute(v() as single)
   declare function save(filename as string) as long
   declare function load(filename as string) as long
   declare function checkmemory() as long
   declare function count() as ulongint
 
end type

constructor Krystal()
end constructor

'size must be a power of 2 (eg. 2,4,8,16,...)
'dilution must be a power of 2
constructor Krystal(size as ulongint,dilution as ulong)
   mask=size-1
   dilutionmask=dilution-1
   if (size and mask)<>0 then error(1)
   if (dilution and dilutionmask)<>0 then error(1)
   redim this.table(mask) as ulongint
   redim this.bvalues(mask) as ubyte
   redim this.dilute(dilutionmask) as single
end constructor

'Find the slot matching the current hash values or if none found return an empty slot in idx.
'If unable to find either set wrongSlot to -1.
sub Krystal.find()
   dim as ulongint probe=hprobe or 1
   key=iif(hkey=0,1,hkey)
   idx=hindex
   wrongSlot=0 'false
   for i as ulong=1 to PROBELIMIT
       idx and=mask
       dim as ulongint t=table(idx)
      if t=0 or t=key then return
      idx+=probe
    next
    wrongSlot=-1 'true
end sub

'Get the byte associated with the given sequence or the closest generalization.
'Returns UNKNOWN if it can't find anything suitable
function Krystal.getByteForSequence(seq() as single) as long
   dim as ulong l=ubound(seq)
    for i as ulong =0 to l
      dilute(i)=seq(i)
   next
   for i as ulong=l+1 to dilutionmask
      dilute(i)=0f
   next
   mix(dilute())
   dim as ulong index=dilutionmask
   resethash()
   nexthash(index)
   find()
   if wrongSlot then return UNKNOWN
   if table(idx)=0 then return UNKNOWN
   dim as ubyte res=bvalues(idx)
   while index<>0
      index-=1
      nexthash(index)
      find()
      if wrongSlot then exit while
      if table(idx)=0 then exit while   
      res=bvalues(idx)
   wend
   return res
end function

'Set the byte value to be associated with the given sequence.
sub Krystal.setByteForSequence(seq() as single,byteFor as ubyte)
   dim as long res=getByteForSequence(seq())
   if res=byteFor then return
   if wrongSlot then return
   if table(idx)=0 then
      table(idx)=key
      bvalues(idx)=byteFor
   end if
end sub

'Reset the hash values.
sub Krystal.resethash()
   hkey=0
   hindex=0
   hprobe=0
end sub

'Pick the next hash values depending on the sign of the next item in the dilute() array.
sub Krystal.nexthash(index as ulong)
   if dilute(index)<0f then
      hkey+=SKIP1
      hindex+=SKIP1
      hprobe+=SKIP1
   else
      hkey+=SKIP2
      hindex+=SKIP2
      hprobe+=SKIP2
   end if
   hkey*=2862933555777941757ull
   hindex*=3202034522624059733ull
   hprobe*=3935559000370003845ull
   hkey xor=hkey shr 31
   hindex xor=hindex shr 31
   hprobe xor=hprobe shr 31
end sub

'Random projection. Spreads out and mixes the information in v() to Gaussian noise.
sub Krystal.mix(v() as single)
   rand=RNDSTART
   signflip(v())
   permute(v())
   wht(v())
   signflip(v())
   permute(v())
   wht(v())
   signflip(v())
   permute(v())
   wht(v())
   signflip(v())
   permute(v())
   wht(v())
end sub

'Pseudorandom floating point sign flip.
sub Krystal.signflip(v() as single)
   for i as ulong =0 to dilutionmask
      rand=rand*1181783497276652981ULL+&hb3731b5c435d0e81ULL
      if ((rand xor (rand shr 31)) and &h80000000ULL)=0 then v(i)=-v(i)
   next
end sub

'Pseudorandom Fisher Yates shuffle (random permutation).
sub Krystal.permute(v() as single)
   for i as ulong =0 to dilutionmask-1
      rand=rand*1181783497276652981ULL+&h51e2c23643c1d329ULL
      dim as ulong r=i+((((rand xor (rand shr 31)) and &hffffffffULL)*(dilutionmask+1-i)) shr 32)
      dim as single a=v(i)
      dim as single b=v(r)
      v(i)=b
      v(r)=a
   next
end sub

'Walsh Hadamard transform
sub Krystal.wht(v() as single)
   dim as ulong h=dilutionmask
   dim as ulong n=h+1
   dim as ulong hstep = 1
   dim as ulong fstep = 2
   while (hstep < n)
      for i as ulong =0 to h step fstep
         dim as ulong j = i
         dim as ulong k = i + hstep
         for m as ulong=0 to hstep-1
            dim as single a1 = v(m + j)
            dim as single b1 = v(m + k)
            v(m + j) = a1 + b1
            v(m + k) = a1 - b1
         next
      next
      hstep = fstep
      fstep += fstep
   wend
end sub   

'returns 0 on success
function Krystal.save(filename as string) as long
   dim as long e,f
   f=freefile()
   open filename for binary access write as #f
   e or=put( #f,,mask)
   e or=put( #f,,dilutionmask)
    e or=put( #f,,table())
    e or=put( #f,,bvalues())
   close #f
   return e
end function

'returns 0 on success
function Krystal.load(filename as string) as long
   dim as integer e,f
   f=freefile()
   open filename for binary access read as #f
   e or=get( #f,,mask)
   e or=get( #f,,dilutionmask)
   redim this.table(mask) as ulongint
   redim this.bvalues(mask) as ubyte
   redim this.dilute(dilutionmask) as single
   e or=get( #f,,table())
   e or=get( #f,,bvalues())
   close #f
   return e
end function

'Check if memory allocation went well after creation or load. Returns 0 if no error.
function Krystal.checkmemory() as long
   if ubound(table)<>mask or ubound(bvalues)<>mask then return -1
   if ubound(dilute)<>dilutionmask then return -1
   return 0
end function

'How full is the table?
function Krystal.count() as ulongint
    dim as ulongint ct
   for i as ulongint=0 to mask
      if table(i)<>0 then ct+=1
   next
   return ct
end function



kimage.bas

Code: Select all

#include "krystal.bas"
#define SEQLEN 100
#define SPREAD 1000
#define SEED 12345678

#define CLUE1 0
#define CLUE2 1000
#define CLUE3 2000

#define BMP1 "a.bmp"
#define BMP2 "b.bmp"

dim shared as long patternX(SEQLEN-1)
dim shared as long patternY(SEQLEN-1)
dim shared as single seq(3*SEQLEN)      ' by 3 colors plus 1
dim shared as Krystal ksystem

sub init(size as ulongint,dilution as ulong)
   dim as double mean=SPREAD*0.5f
   randomize(SEED)
   for i as ulong=0 to SEQLEN-1
      dim as double totalX,totalY
        for j as ulong=1 to SPREAD
         totalX+=rnd()
         totalY+=rnd()
      next
      patternX(i)=totalX-mean         '2D Gaussian distribution
      patternY(i)=totalY-mean
      if patternX(i)=0 and patternY(i)=0 then 'offset never (0,0) since that    
         patternX(i)=iif(rnd()>.5,1,-1)      'is the point to predict
         patternY(i)=iif(rnd()>.5,1,-1)
      end if
   next
   ksystem=Krystal(size,dilution)
end sub

sub digestimage(image as any ptr)
   dim as integer srcW,srcH
   imageinfo(image,srcW,srcH)
   for y as long=0 to srcH-1
      for x as long=0 to srcW-1
         dim as ulong spos,clr
         for i as long=0 to SEQLEN-1
         dim as long x1=x+patternX(i),y1=y+patternY(i)
             if x1<0 or x1>=srcW or y1<0 or y1>=srcH then
                clr=0
            else
               clr=point(x1,y1,image)
            end if
            seq(spos)=clr and 255
            spos+=1
            clr shr=8
            seq(spos)=clr and 255
            spos+=1
            clr shr=8
            seq(spos)=clr and 255
            spos+=1
         next
         clr=point(x,y,image)
         seq(spos)=CLUE1
         ksystem.setByteForSequence(seq(),clr)
         seq(spos)=CLUE2
         ksystem.setByteForSequence(seq(),clr shr 8)
         seq(spos)=CLUE3
         ksystem.setByteForSequence(seq(),clr shr 16)
      next
   next
end sub

sub predictimage(predictedimage as any ptr,srcimage as any ptr)
   dim as integer pW,pH
   imageInfo(predictedimage,pW,pH)
   for y as long=0 to pH-1
      for x as long=0 to pW-1
         dim as ulong spos,clr
         for i as long=0 to SEQLEN-1
             dim as long x1=x+patternX(i),y1=y+patternY(i)
             if x1<0 or x1>=pW or y1<0 or y1>=pH then
                clr=0
            else
               clr=point(x1,y1,srcimage)
            end if
            seq(spos)=clr and 255
            spos+=1
            clr shr=8
            seq(spos)=clr and 255
            spos+=1
            clr shr=8
            seq(spos)=clr and 255
            spos+=1
         next
         seq(spos)=CLUE3
         clr=ksystem.getByteForSequence(seq())
         clr shl=8
         seq(spos)=CLUE2
         clr or=ksystem.getByteForSequence(seq())
         clr shl=8
         seq(spos)=CLUE1
         clr or=ksystem.getByteForSequence(seq())
         pset predictedimage,(x,y),clr
      next
   next
end sub

'from FB documentation
Function bmp_load( ByRef filename As Const String ) As Any Ptr
    Dim As Integer filenum, bmpwidth, bmpheight
    Dim As Any Ptr img
    filenum = FreeFile()
    If Open( filename For Binary Access Read As #filenum ) <> 0 Then Return 0
    Get #filenum, 19, bmpwidth
    Get #filenum, 23, bmpheight
    Close #filenum
    img = ImageCreate( bmpwidth, Abs(bmpheight) )
    If img = 0 Then Return 0
    If BLoad( filename, img ) <> 0 Then ImageDestroy( img ): Return 0
    Return img
End Function

' returns 0 on success
function digestBMP(filename as string) as long
   dim as any ptr img=bmp_load(filename)
   if img=0 then return -1
   digestimage(img)
   imagedestroy(img)
   return 0
end function

screenres 1000,480,32
init(65536*32,512)
dim as any ptr img1=bmp_load("a.bmp")
dim as any ptr img2=bmp_load("b.bmp")
dim as any ptr img3
put (20,20),img1

digestimage(img1) ' retraining a few times can help remove any unresolved conflicts
digestimage(img1)
digestimage(img1)

cls
print "Count "&ksystem.count(),"out of "&(1+ksystem.mask)
dim as integer w,h
imageinfo(img2,w,h)
img3=imagecreate(w,h)

put (10,20),img2,PSET
predictimage(img3,img2)
put (520,20),img3,PSET 'Pixel values predicted for BMP2 after training with BMP1

imagedestroy(img1)
imagedestroy(img2)
imagedestroy(img3)
sleep
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Mar 07, 2015 1:45

I guess if you wanted to be dismissive you could say all it is doing is embedding a decision tree in a hash table. Anyway I learned some new things and got some new perspectives. I'm not sure how the code compares with other ways of constructing decision trees. It seems to be very fast anyway. At least it would result in getting definite behaviour out of a robot from ambiguous inputs, then you could use reinforcement learning to say "good idea" or "bad idea" to that behaviour.
dafhi
Posts: 1275
Joined: Jun 04, 2005 9:51

Re: Artistic license

Postby dafhi » Mar 07, 2015 10:10

my interest in ai isn't yet strong enough to try to figure out what's going on. but i'll continue to fiddle with it because i think there's something special with your code. i added stuff to make experimentation easier

Code: Select all

'screenres 1000,480,32
'init(65536*32,512)
'dim as any ptr img1=bmp_load("a.bmp")
'...
'Sleep

type tImage

  'image helper by dafhi  2015 Mar 3
 
  '1. quick reference - ScreenRes, ScreenInfo, ScreenSet, ImageCreate, ImageInfo
  '2. automatic ScreenInfo & ImageInfo via screen_init & create, respectively ..
  ' - info sent to w,h,bpp,bypp,pitch
  '3. automatic ImageDestroy
 
  as any ptr              img, pixels, p_page(Any)
  as ulong ptr            pixels32
  as integer              w,h,bpp,bypp,pitch,num_pages,flags, wm,hm,pitchBy,ub1d,is_screen
  as single               midx,midy,diagonal
  declare operator        cast  as any ptr
  Declare Sub             screen_init(wid As UShort = 1, hgt As UShort = 1, bpp_ as UInteger = 32, numPages as integer = 1, Flags as integer = 0)
  Declare Function        create(pWid As UShort = 1, pHgt As UShort = 1, color As Ulong=&HFF000000) As Any ptr
  declare function        bmp_load(ByRef filename As String) As Any Ptr
  Declare Sub             cls(pColor As Ulong=RGB(0,0,0))
  Declare Destructor
 Private:
  declare sub             vars_common
  Declare Sub             destroy
end type
Sub tImage.Destroy()
  If img <> 0 Then ImageDestroy img: img = 0
End Sub
Destructor tImage
  Destroy
End Destructor
operator tImage.cast as any ptr
  return img
end operator
sub tImage.vars_common
  wm=w-1: hm=h-1:  midx = wm/2: midy = hm/2: diagonal = sqr(midx*midx+midy*midy)
  pitchBy = pitch \ bypp:  ub1d=w*h-1: pixels32 = pixels
end sub
Sub tImage.screen_init(Wid As UShort, Hgt As UShort, bpp as UInteger, numpages as integer, flags as integer)
  Destroy ' in case the image is being re-purposed
  num_pages = numpages: this.bpp = bpp: this.flags=flags
  ScreenRes Wid,Hgt,bpp,numPages,Flags
  ScreenInfo w,h, bpp, bypp, pitch:  pixels = ScreenPtr
  vars_common
  redim p_page(numpages-1)
  for page as integer=0 to numpages-1
    ScreenSet page
    p_page(page) = ScreenPtr
  next
  if numPages > 1 then screenset 0,1 'work_page, visible_page
  if p_page(0) <> 0 then is_screen = -1
End sub
Function tImage.create(wid As UShort, hgt As UShort, col As ULong) As Any Ptr
  Destroy ' in case the image is being re-purposed
  img = ImageCreate( wid, hgt, col, 32 )
  ImageInfo img, w, h, bypp, pitch, pixels:  bpp = bypp * 8
  vars_common
  is_screen=0:  Return img
End Function
function tImage.bmp_load( ByRef filename As String ) As Any Ptr
  filename = exepath & "\" & filename
  dim as integer  filenum = freefile
  If Open( filename For Binary Access Read As #filenum ) <> 0 Then Return 0
  Get #filenum, 19, w
  Get #filenum, 23, h
  close #filenum
  create w, h
  if img = 0 then return 0
  If BLoad( filename, img ) <> 0 Then Return 0
  Return img
End Function
Sub tImage.Cls(pColor As ULong)
  select case bpp
  case 32
    for I as ulong ptr = pixels32 to pixels32 + ub1d: *I = pColor: Next
  end select
End Sub

sub Show(img as tImage, x as integer, y as integer, outline as integer = 1, col as ulong = rgb(255,255,0))
  put (x,y),img,pset
  if outline then line (x,y)-(x+img.wm,y+img.hm), col,b
end sub


dim as tImage buf, img1,img2,img3
buf.screen_init 1000,480

init(65536*32,512)

'img1.bmp_load("a.bmp")
img1.create 100,100
pset img1, (94,4), rgb(255,255,255)
Show img1, 2,20

digestimage(img1) ' retraining a few times can help remove any unresolved conflicts
digestimage(img1)
digestimage(img1)

'img2.bmp_load("b.bmp")
img2.create img1.w,img1.h
pset img2, (4,4), rgb(255,255,255)

'cls
print "Count "&ksystem.count(),"out of "&(1+ksystem.mask)
img3.create img2.w, img2.h

show img2, 3+img1.w,20
predictimage(img3,img2)
Show img3, 4+img1.w*2,20 'Pixel values predicted for BMP2 after training with BMP1

sleep
sean_vn
Posts: 283
Joined: Aug 06, 2012 8:26

Re: Artistic license

Postby sean_vn » Mar 08, 2015 14:39

I'll experiment with what you have added. It seems initially at least that you can get some kind of reasonable function approximator with random projection with decision trees. I mean the sort of function approximator that would be good for robotics. Well, who knows really? I certainly don't!
In terms of memory based computing I have just stumbled upon this:
http://storageswiss.com/2015/02/17/will-microns-automata-processor-solve-big-data/
http://www.edn.com/design/systems-design/4432795/2/The-Automata-Processor---Practical-processing-in-memory--Pt-2-
Unfortunately Mircon won't let me download the SDK for their product. If the fundamental ideas for that are relatively simple then I could experiment with it. But certainly I am not interested in getting involved in super complex hardware such as Nvidia CUDA on a hobby basis.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests