Artistic license

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

Artistic license

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by 1000101 »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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

Post by sean_vn »

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: 1640
Joined: Jun 04, 2005 9:51

Re: Artistic license

Post by dafhi »

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

Post by sean_vn »

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 ... -big-data/
http://www.edn.com/design/systems-desig ... ory--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.
Post Reply