+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Vince's Corner Takeout (/showthread.php?tid=270)
RE: Vince's Corner Takeout - vince - 08-19-2022
Vince Text Editor
New mod inspired by B+'s new GUI. This is a demonstration of using _MEM, _MEMNEW, and _MEMPUT to create dynamically allocated doubly linked lists like you would in C (with malloc and pointers) featured as a library in subs addNodeNext, addNodePrev, rmNode, nextNode, prevNode, lenNode, readNode, writeNode, newList, printList, rmList. The demo features keyboard editable scrollable textboxes in draggable resizeable windows using TWM style resizing mechanism. The black screen is a demo of a command line. Special thanks to keybone for modding sub drawWin to look more like BeOS
![[Image: UyQuNAY.png]](https://i.imgur.com/UyQuNAY.png)
Code: (Select All)
DEFINT A-Z
CONST sw = 800
CONST sh = 600
CONST winBarH = 25
CONST winMinW = 50
CONST winMinH = 50
CONST fontSize = 16
TYPE nodeType
str AS _MEM
strLen AS INTEGER
n AS _MEM
p AS _MEM
END TYPE
TYPE listType
head AS _MEM
tail AS _MEM
cur AS _MEM
cx AS INTEGER
cy AS INTEGER
scroll AS INTEGER
scrollmax AS INTEGER
END TYPE
TYPE winType
x AS INTEGER
y AS INTEGER
w AS INTEGER
h AS INTEGER
img AS LONG
cap AS STRING * 128
pid AS INTEGER
text AS listType
END TYPE
DIM SHARED mx, my, mbr, mbl, mw
DIM tmem AS _MEM
DIM SHARED win(50) AS winType, wn
win(0).x = 10
win(0).y = 10
win(0).w = 320
win(0).h = 240
win(0).img = _NEWIMAGE(win(0).w + 1, win(0).h + 1, 32)
win(0).cap = "command prompt 0"
win(0).pid = 2
newList win(0).text
addNodeNext win(0).text.cur, ">", win(0).text.head, win(0).text
win(0).text.cx = 1
nextNode win(0).text.cur, win(0).text.head
win(1).x = 400
win(1).y = 10
win(1).w = 320
win(1).h = 240
win(1).cap = "textbox 1"
win(1).img = _NEWIMAGE(win(1).w + 1, win(1).h + 1, 32)
win(1).pid = 1
newList win(1).text
addNodeNext win(1).text.cur, "", win(1).text.head, win(1).text
nextNode win(0).text.cur, win(0).text.head
win(2).x = 200
win(2).y = 300
win(2).w = 520
win(2).h = 240
win(2).cap = "textbox 2"
win(2).img = _NEWIMAGE(win(2).w + 1, win(2).h + 1, 32)
win(2).pid = 1
newList win(2).text
addNodeNext win(2).text.cur, "I", win(2).text.head, win(2).text
addNodeNext win(2).text.cur, "am", win(2).text.cur, win(2).text
addNodeNext win(2).text.cur, "a", win(2).text.cur, win(2).text
addNodeNext win(2).text.cur, "textbox", win(2).text.cur, win(2).text
nextNode win(2).text.cur, win(2).text.head
win(3).x = 15
win(3).y = 305
win(3).w = 160
win(3).h = 120
win(3).cap = "about"
win(3).img = _NEWIMAGE(win(3).w + 1, win(3).h + 1, 32)
win(3).pid = 0
'newList win(3).text
'addNodeNext win(3).text.cur, "", win(3).text.head, win(3).text
wn = 3
DIM SHARED bg AS _INTEGER64, p1 AS _INTEGER64
p1 = _NEWIMAGE(sw, sh, 32)
bg = _NEWIMAGE(sw, sh, 32)
_DEST bg
LINE (0, 0)-(sw, sh), _RGB(0, 0, 0), BF
FOR y = 0 TO sh STEP 4
LINE (0, y)-(sw, y), _RGB(42, 42, 42), , &H8888
LINE (1, y + 1)-(sw, y + 1), _RGB(42, 42, 42), , &H8888
LINE (3, y + 2)-(sw, y + 2), _RGB(42, 42, 42), , &H8888
LINE (2, y + 3)-(sw, y + 3), _RGB(42, 42, 42), , &H8888
NEXT
'circle (sw\2, sh\2),100,_rgb(0,50,105)
'for a# = 0 to 2*3.141593 step 2*3.141593/6
' x# = 100*cos(a#) + sw\2
' y# = 100*sin(a#) + sh\2
' circle(x#, y#),100,_rgb(0,50,105)
' for b# = 0 to 2*3.141593 step 2*3.141593/6
' xx# = x# + 100*cos(b#)
' yy# = y# + 100*sin(b#)
' circle(xx#, yy#),100,_rgb(0,50,105)
' for c# = 0 to 2*3.141593 step 2*3.141593/6
' circle(xx# + 100*cos(b#), yy# + 100*sin(b#)),100,_rgb(0,50,105)
' next
' next
'next
_DEST 0
SCREEN _NEWIMAGE(sw, sh, 32)
FOR i = 0 TO wn
drawWin (i)
NEXT
redraw
DIM temp AS winType
DIM k AS LONG
DO
mw = 0
getMouse
k = _KEYHIT
IF wn >= 0 THEN
'''process current window left mouse button events
IF mbl THEN
'mouse over current window
tabw = tabWidth(0)
IF mbox(win(0).x, win(0).y, win(0).w, win(0).h) THEN
IF mbox(win(0).x, win(0).y, win(0).w, winBarH) AND NOT mbox(win(0).x + tabw, win(0).y, win(0).w - tabw, winBarH) THEN
IF mbox(win(0).x + tabw - winBarH + 3, win(0).y + 3, winBarH - 6, winBarH - 6) THEN
'''resize
_DEST p1
redraw
_DEST 0
boxx = win(0).x
boxy = win(0).y
boxw = win(0).w
boxh = win(0).h
drawBox boxx, boxy, boxw, boxh
_DISPLAY
stuck = 0
omx = mx
omy = my
DO WHILE mbl
getMouse
IF omx <> mx OR omy <> my THEN
IF NOT mbox(boxx, boxy, boxw, boxh) THEN
IF mx <= boxx THEN
stuck = stuck OR 1
ELSEIF mx >= boxx + boxw THEN
stuck = stuck OR 2
END IF
IF my <= boxy THEN
stuck = stuck OR 4
ELSEIF my >= boxy + boxh THEN
stuck = stuck OR 8
END IF
END IF
IF stuck AND 1 THEN
boxx = mx
boxw = win(0).w + win(0).x - mx
IF boxw <= 50 THEN stuck = stuck XOR 1
ELSEIF stuck AND 2 THEN
boxx = win(0).x
boxw = mx - win(0).x
IF boxw <= 50 THEN stuck = stuck XOR 2
END IF
IF stuck AND 4 THEN
boxy = my
boxh = win(0).h + win(0).y - my
IF boxh <= 50 THEN stuck = stuck XOR 4
ELSEIF stuck AND 8 THEN
boxy = win(0).y
boxh = my - win(0).y
IF boxh <= 50 THEN stuck = stuck XOR 8
END IF
_PUTIMAGE , p1
drawBox boxx, boxy, boxw, boxh
_DISPLAY
omx = mx
omy = my
END IF
LOOP
win(0).x = boxx
win(0).y = boxy
win(0).w = boxw
win(0).h = boxh
_FREEIMAGE win(0).img
win(0).img = _NEWIMAGE(win(0).w + 1, win(0).h + 1, 32)
SELECT CASE win(0).pid
CASE 1
win(0).text.cx = 0
FOR i = 1 TO win(0).text.cy
prevNode win(0).text.cur, win(0).text.cur
NEXT
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
win(0).text.cy = 0
CASE 2
win(0).text.cx = 1
FOR i = 1 TO win(0).text.cy
prevNode win(0).text.cur, win(0).text.cur
NEXT
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
win(0).text.cy = 0
END SELECT
drawWin (0)
redraw
_DISPLAY
ELSEIF mbox(win(0).x + 3, win(0).y + 3, winBarH - 6, winBarH - 6) THEN
'''close
DO WHILE mbr
getMouse
LOOP
closeWin (0)
ELSE
'''drag
'partial redraw
_DEST p1
_PUTIMAGE , bg
FOR i = wn TO 1 STEP -1
_PUTIMAGE (win(i).x, win(i).y), win(i).img
NEXT
_DEST 0
omx = mx
omy = my
owx = mx - win(0).x
owy = my - win(0).y
DO WHILE mbl
getMouse
IF mx <> omx OR my <> omy THEN
_PUTIMAGE (win(0).x, win(0).y), p1, , (win(0).x, win(0).y)-(win(0).x + win(0).w, win(0).y + win(0).h)
win(0).x = mx - owx
win(0).y = my - owy
'''''
'''''''''''fixxx thisss!!!
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
omx = mx
omy = my
END IF
LOOP
END IF
END IF
ELSE
'mouse over other windows
FOR i = 1 TO wn
tabw = tabWidth(i)
IF mbox(win(i).x, win(i).y, win(i).w, win(i).h) AND NOT mbox(win(i).x + tabw, win(i).y, win(i).w - tabw, winBarH) THEN
temp = win(i)
FOR j = i TO 1 STEP -1
win(j) = win(j - 1)
NEXT
win(0) = temp
drawWin (0)
drawWin (1)
redraw
_DISPLAY
EXIT FOR
END IF
NEXT
END IF
END IF
'''
'''process current window right mouse button events
IF mbr THEN
'''close [old]
'if mbox(win(0).x, win(0).y, win(0).w, winBarH) then
' do while mbr
' getMouse
' loop
' closeWin(0)
'end if
END IF
'''
'''process current window mouse wheel events
IF mw <> 0 THEN
SELECT CASE win(0).pid
CASE 1
'''scroll
IF mw < 0 THEN
'scrolling up
IF win(0).text.scroll > 0 THEN
win(0).text.scroll = win(0).text.scroll - 1
IF win(0).text.cy < (win(0).h - winBarH - 6) \ fontSize - 1 THEN
win(0).text.cy = win(0).text.cy + 1
ELSEIF -1 THEN
prevNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
END IF
END IF
'scrolling down
ELSEIF mw > 0 THEN
IF win(0).text.scroll + mw < win(0).text.scrollmax THEN
win(0).text.scroll = win(0).text.scroll + 1
IF win(0).text.cy > 0 THEN
win(0).text.cy = win(0).text.cy - 1
ELSEIF -1 THEN
nextNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
END IF
END IF
END IF
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END SELECT
END IF
'''
'''process current window keyboard controls
IF k <> 0 THEN
SELECT CASE win(0).pid
'about window
CASE 0
'textbox
CASE 1
SELECT CASE k
'right
CASE 19712
IF win(0).text.cx < LEN(readNode$(win(0).text.cur)) AND win(0).text.cx < (win(id).w - 8) \ 8 THEN
win(0).text.cx = win(0).text.cx + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
'left
CASE 19200
IF win(0).text.cx > 0 THEN win(0).text.cx = win(0).text.cx - 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
'down
CASE 20480
IF win(0).text.cy < (win(0).h - winBarH - 6) \ fontSize - 1 THEN
IF win(0).text.cy + win(0).text.scroll + 1 < win(0).text.scrollmax THEN
win(0).text.cy = win(0).text.cy + 1
nextNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
ELSEIF win(0).text.scroll + win(0).text.cy + 1 < win(0).text.scrollmax THEN
win(0).text.scroll = win(0).text.scroll + 1
nextNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
'up
CASE 18432
IF win(0).text.cy > 0 THEN
win(0).text.cy = win(0).text.cy - 1
prevNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
ELSEIF win(0).text.scroll > 0 THEN
win(0).text.scroll = win(id).text.scroll - 1
prevNode win(0).text.cur, win(0).text.cur
curlen = lenNode(win(0).text.cur)
IF win(0).text.cx > curlen THEN win(0).text.cx = curlen
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
'enter
CASE 13
IF win(0).text.cx = 0 THEN
addNodePrev win(0).text.cur, "", win(0).text.cur, win(0).text
nextNode win(0).text.cur, win(0).text.cur
ELSEIF win(0).text.cx >= lenNode(win(0).text.cur) THEN
addNodeNext win(0).text.cur, "", win(0).text.cur, win(0).text
ELSEIF -1 THEN
rn$ = readNode$(win(0).text.cur)
curlen = lenNode(win(0).text.cur)
lt$ = LEFT$(rn$, win(0).text.cx)
rt$ = MID$(rn$, win(0).text.cx + 1, curlen - cx - 1)
writeNode win(0).text.cur, lt$
addNodeNext win(0).text.cur, rt$, win(0).text.cur, win(0).text
END IF
win(0).text.cx = 0
IF win(0).text.cy < (win(0).h - winBarH - 6) \ fontSize - 1 THEN
IF win(0).text.cy + win(0).text.scroll + 1 < win(0).text.scrollmax THEN
win(0).text.cy = win(0).text.cy + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
ELSEIF win(0).text.scroll + win(0).text.cy + 1 < win(0).text.scrollmax THEN
win(0).text.scroll = win(0).text.scroll + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
'backspace
CASE 8
IF win(0).text.cx > 0 THEN
rn$ = readNode$(win(0).text.cur)
lt$ = LEFT$(rn$, win(0).text.cx - 1)
rt$ = MID$(rn$, win(0).text.cx + 1, curlen - cx - 1)
writeNode win(0).text.cur, lt$ + rt$
win(0).text.cx = win(0).text.cx - 1
ELSEIF win(0).text.cx = 0 THEN
IF win(0).text.cy > 0 OR win(0).text.scroll > 0 THEN
s$ = readNode$(win(0).text.cur)
tmem = win(0).text.cur
prevNode win(0).text.cur, win(0).text.cur
win(0).text.cx = lenNode(win(0).text.cur)
s$ = readNode$(win(0).text.cur) + s$
writeNode win(0).text.cur, s$
rmNode tmem, win(0).text
IF win(0).text.cy > 0 THEN
win(0).text.cy = win(0).text.cy - 1
ELSEIF win(0).text.cy = 0 THEN
IF win(0).text.scroll > 0 THEN
win(0).text.scroll = win(0).text.scroll - 1
END IF
END IF
END IF
END IF
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
CASE 32 TO 126
IF win(0).text.cx < (win(id).w - 8) \ 8 THEN
rn$ = readNode$(win(0).text.cur)
IF win(0).text.cx = 0 THEN
rn$ = "$" + rn$
writeNode win(0).text.cur, CHR$(k) + readNode$(win(0).text.cur)
ELSEIF win(0).text.cx >= lenNode(win(0).text.cur) THEN
writeNode win(0).text.cur, readNode$(win(0).text.cur) + CHR$(k)
ELSEIF -1 THEN
curlen = lenNode(win(0).text.cur)
writeNode win(0).text.cur, LEFT$(rn$, win(0).text.cx) + CHR$(k) + MID$(rn$, win(0).text.cx + 1, curlen - cx - 1)
END IF
win(0).text.cx = win(0).text.cx + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
END SELECT
'command prompt
CASE 2
SELECT CASE k
'right
CASE 19712
IF win(0).text.cx < LEN(readNode$(win(0).text.cur)) AND win(0).text.cx < (win(id).w - 8) \ 8 THEN
win(0).text.cx = win(0).text.cx + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
'left
CASE 19200
IF win(0).text.cx > 0 THEN win(0).text.cx = win(0).text.cx - 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
'enter
CASE 13
result$ = ""
rn$ = readNode$(win(0).text.cur)
IF cmd(result$, RIGHT$(rn$, LEN(rn$) - 1), 0) THEN
addNodePrev win(0).text.cur, rn$, win(0).text.cur, win(0).text
addNodeNext win(0).text.cur, result$, win(0).text.cur, win(0).text
nextNode win(0).text.cur, win(0).text.cur
writeNode win(0).text.cur, ">"
win(0).text.cx = 1
IF win(0).text.cy < (win(0).h - winBarH - 6) \ fontSize - 1 THEN
IF win(0).text.cy + win(0).text.scroll + 1 < win(0).text.scrollmax THEN
win(0).text.cy = win(0).text.cy + 2
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
ELSEIF win(0).text.scroll + win(0).text.cy + 1 < win(0).text.scrollmax THEN
win(0).text.scroll = win(0).text.scroll + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
ELSE
closeWin (0)
END IF
'backspace
CASE 8
IF win(0).text.cx > 1 THEN
rn$ = readNode$(win(0).text.cur)
lt$ = LEFT$(rn$, win(0).text.cx - 1)
rt$ = MID$(rn$, win(0).text.cx + 1, curlen - cx - 1)
writeNode win(0).text.cur, lt$ + rt$
win(0).text.cx = win(0).text.cx - 1
END IF
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
CASE 32 TO 126
IF win(0).text.cx < (win(id).w - 8) \ 8 THEN
rn$ = readNode$(win(0).text.cur)
IF win(0).text.cx = 0 THEN
rn$ = "$" + rn$
writeNode win(0).text.cur, CHR$(k) + readNode$(win(0).text.cur)
ELSEIF win(0).text.cx >= lenNode(win(0).text.cur) THEN
writeNode win(0).text.cur, readNode$(win(0).text.cur) + CHR$(k)
ELSEIF -1 THEN
curlen = lenNode(win(0).text.cur)
writeNode win(0).text.cur, LEFT$(rn$, win(0).text.cx) + CHR$(k) + MID$(rn$, win(0).text.cx + 1, curlen - cx - 1)
END IF
win(0).text.cx = win(0).text.cx + 1
drawWin (0)
_PUTIMAGE (win(0).x, win(0).y), win(0).img
_DISPLAY
END IF
END SELECT
END SELECT
END IF
'''
END IF
LOOP UNTIL k = 27
SYSTEM
FUNCTION cmd (result AS STRING, in AS STRING, id)
SELECT CASE in
CASE "version"
result = "vwm version 2"
cmd = -1
CASE "time"
result = STR$(TIMER)
cmd = -1
CASE "exit"
cmd = 0
CASE ELSE
result = "error"
cmd = -1
END SELECT
END SUB
SUB getMouse ()
DO
mx = _MOUSEX
my = _MOUSEY
mbl = _MOUSEBUTTON(1)
mbr = _MOUSEBUTTON(2)
mw = mw + _MOUSEWHEEL
LOOP WHILE _MOUSEINPUT
END SUB
SUB redraw ()
_PUTIMAGE , bg
FOR i = wn TO 0 STEP -1
_PUTIMAGE (win(i).x, win(i).y), win(i).img
NEXT
END SUB
SUB closeWin (id)
_FREEIMAGE win(id).img
SELECT CASE win(id).pid
CASE 1 TO 2
rmList win(id).text
END SELECT
wn = wn - 1
FOR i = id TO wn
win(i) = win(i + 1)
NEXT
redraw
_DISPLAY
END SUB
SUB resizeWin (id)
END SUB
FUNCTION tabWidth (id)
s$ = RTRIM$(win(id).cap)
IF (LEN(s$) * 8 + winBarH * 4) > win(id).w THEN
tabWidth = win(id).w
ELSE
tabWidth = winBarH * 4 + LEN(s$) * 8
END IF
END FUNCTION
SUB drawWin (id)
_DEST win(id).img
'LINE (0, winBarH)-STEP(win(id).w, win(id).h - winBarH), _RGB(0, 0, 0), BF
'LINE (0, winBarH)-STEP(win(id).w, win(id).h - winBarH), _RGB(255, 255, 255), B
s$ = RTRIM$(win(id).cap)
IF (LEN(s$) * 8 + winBarH * 4) > win(id).w THEN
ss$ = LEFT$(s$, (win(id).w - winBarH * 4) \ 8)
tabw = win(id).w
ELSE
ss$ = s$
tabw = winBarH * 4 + LEN(s$) * 8
END IF
'line (0, 0)-step(tabw, winBarH),_rgb(0,0,0),bf
'line (0, 0)-step(tabw, winBarH),_rgb(255,255,255),b
'line (4, 4)-step(winBarH-8, winBarH-8),_rgb(255,255,255),b
'line (tabw-winBarH+4, 4)-step(winBarH-8, winBarH-8),_rgb(255,255,255),b
'''BeOS
DIM g1 AS LONG, g2 AS LONG, g3 AS LONG
IF id = 0 THEN
'g1 = _RGB(255, 255, 82)
'g2 = _RGB(255, 206, 0)
'g3 = _RGB(173, 123, 0)
c0 = _RGBA32(255, 255, 57, 255)
c1 = _RGBA32(255, 239, 33, 255)
c2 = _RGBA32(255, 206, 0, 255)
c3 = _RGBA32(239, 181, 0, 255)
c4 = _RGBA32(214, 156, 0, 255)
ELSE
'g1 = _RGB(255, 255, 255)
'g2 = _RGB(239, 239, 239)
'g3 = _RGB(156, 156, 156)
c0 = _RGBA32(255, 255, 255, 255)
c1 = c0
c2 = _RGBA32(239, 239, 239, 255)
c3 = _RGBA32(222, 214, 222, 255)
c4 = _RGBA32(198, 189, 198, 255)
END IF
'255.255.255 - c0/c1
'239.239.239 - c2
'222.214.222 - c3
'198.189.198 - c4
LINE (0, 0)-(tabw, 0), _RGB(156, 156, 156)
LINE (tabw + 1, winBarH)-(win(id).w - 1, winBarH), _RGB(156, 156, 156)
LINE (0, 0)-(0, win(id).h - 1), _RGB(156, 156, 156)
LINE (tabw, 1)-(tabw, winBarH), _RGB(99, 99, 99)
LINE (0, win(id).h)-(win(id).w, win(id).h), _RGB(99, 99, 99)
LINE (win(id).w, winBarH - 1)-(win(id).w, win(id).h), _RGB(99, 99, 99)
LINE (1, win(id).h - 1)-(win(id).w - 1, win(id).h - 1), _RGB(140, 140, 140)
LINE (win(id).w - 1, win(id).h - 1)-(win(id).w - 1, winBarH + 1), _RGB(140, 140, 140)
LINE (1, winBarH + 1)-(1, win(id).h - 2), _RGB(255, 255, 255)
LINE (tabw - 1, winBarH + 1)-(win(id).w - 2, winBarH + 1), _RGB(255, 255, 255)
LINE (2, winBarH + 1)-(tabw - 2, winBarH + 1), _RGB(222, 222, 222)
LINE (2, winBarH + 2)-(win(id).w - 2, win(id).h - 2), _RGB(222, 222, 222), B
LINE (3, winBarH + 3)-(3, win(id).h - 3), _RGB(156, 156, 156)
LINE (3, winBarH + 3)-(win(id).w - 4, winBarH + 3), _RGB(156, 156, 156)
LINE (4, win(id).h - 3)-(win(id).w - 4, win(id).h - 3), _RGB(255, 255, 255)
LINE (win(id).w - 3, win(id).h - 3)-(win(id).w - 3, winBarH + 3), _RGB(255, 255, 255)
LINE (1, 1)-(tabw - 1, 1), c1
LINE (1, 1)-(1, winBarH), c1
LINE (2, 2)-(tabw - 2, winBarH), c2, BF
LINE (tabw - 1, 2)-(tabw - 1, winBarH), c3
LeftButtonStartX = 6
LeftButtonStartY = 6
LINE (LeftButtonStartX + 0, LeftButtonStartY + 0)-(LeftButtonStartX + 13, LeftButtonStartY + 0), c4
LINE (LeftButtonStartX + 0, LeftButtonStartY + 0)-(LeftButtonStartX + 0, LeftButtonStartY + 13), c4
LINE (LeftButtonStartX + 1, LeftButtonStartY + 1)-(LeftButtonStartX + 13, LeftButtonStartY + 1), c0
LINE (LeftButtonStartX + 1, LeftButtonStartY + 1)-(LeftButtonStartX + 1, LeftButtonStartY + 13), c0
LINE (LeftButtonStartX + 1, LeftButtonStartY + 13)-(LeftButtonStartX + 13, LeftButtonStartY + 13), c0
LINE (LeftButtonStartX + 13, LeftButtonStartY + 13)-(LeftButtonStartX + 13, LeftButtonStartY + 1), c0
LINE (LeftButtonStartX + 2, LeftButtonStartY + 12)-(LeftButtonStartX + 12, LeftButtonStartY + 12), c4
LINE (LeftButtonStartX + 12, LeftButtonStartY + 12)-(LeftButtonStartX + 12, LeftButtonStartY + 2), c4
LINE (LeftButtonStartX + 6, LeftButtonStartY + 11)-(LeftButtonStartX + 11, LeftButtonStartY + 11), c3
LINE (LeftButtonStartX + 7, LeftButtonStartY + 10)-(LeftButtonStartX + 11, LeftButtonStartY + 10), c3
LINE (LeftButtonStartX + 9, LeftButtonStartY + 9)-(LeftButtonStartX + 11, LeftButtonStartY + 9), c3
LINE (LeftButtonStartX + 10, LeftButtonStartY + 8)-(LeftButtonStartX + 11, LeftButtonStartY + 8), c3
LINE (LeftButtonStartX + 9, LeftButtonStartY + 7)-(LeftButtonStartX + 11, LeftButtonStartY + 7), c3
PSET (LeftButtonStartX + 11, LeftButtonStartY + 6), c3
LINE (LeftButtonStartX + 9, LeftButtonStartY + 8)-(LeftButtonStartX + 8, LeftButtonStartY + 9), c2
LINE (LeftButtonStartX + 8, LeftButtonStartY + 8)-(LeftButtonStartX + 7, LeftButtonStartY + 9), c3
LINE (LeftButtonStartX + 11, LeftButtonStartY + 3)-(LeftButtonStartX + 10, LeftButtonStartY + 4), c1
LINE (LeftButtonStartX + 6, LeftButtonStartY + 10)-(LeftButtonStartX + 5, LeftButtonStartY + 11), c2
LINE (LeftButtonStartX + 11, LeftButtonStartY + 5)-(LeftButtonStartX + 10, LeftButtonStartY + 6), c2
LINE (LeftButtonStartX + 11, LeftButtonStartY + 4)-(LeftButtonStartX + 4, LeftButtonStartY + 11), c2
LINE (LeftButtonStartX + 9, LeftButtonStartY + 5)-(LeftButtonStartX + 5, LeftButtonStartY + 9), c2
LINE (LeftButtonStartX + 4, LeftButtonStartY + 10)-(LeftButtonStartX + 3, LeftButtonStartY + 11), c1
LINE (LeftButtonStartX + 11, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 11), c2
LINE (LeftButtonStartX + 10, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 10), c1
LINE (LeftButtonStartX + 8, LeftButtonStartY + 3)-(LeftButtonStartX + 3, LeftButtonStartY + 8), c2
LINE (LeftButtonStartX + 8, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 8), c1
LINE (LeftButtonStartX + 7, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 7), c1
LINE (LeftButtonStartX + 6, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 6), c1
LINE (LeftButtonStartX + 5, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 5), c1
LINE (LeftButtonStartX + 4, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 4), c0
LINE (LeftButtonStartX + 3, LeftButtonStartY + 2)-(LeftButtonStartX + 2, LeftButtonStartY + 3), c1
PSET (LeftButtonStartX + 2, LeftButtonStartY + 2), c0
PSET (LeftButtonStartX + 9, LeftButtonStartY + 2), c1
PSET (LeftButtonStartX + 2, LeftButtonStartY + 9), c1
RightButtonStartX = (tabw - 14) - 6
RightButtonStartY = 6
LINE (RightButtonStartX + 0, RightButtonStartY + 0)-(RightButtonStartX + 7, RightButtonStartY + 0), c4
LINE (RightButtonStartX + 0, RightButtonStartY + 0)-(RightButtonStartX + 0, RightButtonStartY + 7), c4
LINE (RightButtonStartX + 1, RightButtonStartY + 1)-(RightButtonStartX + 8, RightButtonStartY + 1), c0
LINE (RightButtonStartX + 1, RightButtonStartY + 1)-(RightButtonStartX + 1, RightButtonStartY + 8), c0
LINE (RightButtonStartX + 8, RightButtonStartY + 1)-(RightButtonStartX + 8, RightButtonStartY + 8), c0
LINE (RightButtonStartX + 1, RightButtonStartY + 8)-(RightButtonStartX + 8, RightButtonStartY + 8), c0
LINE (RightButtonStartX + 2, RightButtonStartY + 7)-(RightButtonStartX + 7, RightButtonStartY + 7), c4
LINE (RightButtonStartX + 7, RightButtonStartY + 2)-(RightButtonStartX + 7, RightButtonStartY + 7), c4
LINE (RightButtonStartX + 9, RightButtonStartY + 3)-(RightButtonStartX + 13, RightButtonStartY + 3), c4
LINE (RightButtonStartX + 9, RightButtonStartY + 4)-(RightButtonStartX + 13, RightButtonStartY + 4), c0
LINE (RightButtonStartX + 13, RightButtonStartY + 4)-(RightButtonStartX + 13, RightButtonStartY + 13), c0
LINE (RightButtonStartX + 13, RightButtonStartY + 13)-(RightButtonStartX + 4, RightButtonStartY + 13), c0
LINE (RightButtonStartX + 4, RightButtonStartY + 13)-(RightButtonStartX + 4, RightButtonStartY + 9), c0
LINE (RightButtonStartX + 3, RightButtonStartY + 13)-(RightButtonStartX + 3, RightButtonStartY + 9), c4
LINE (RightButtonStartX + 12, RightButtonStartY + 5)-(RightButtonStartX + 12, RightButtonStartY + 12), c4
LINE (RightButtonStartX + 12, RightButtonStartY + 12)-(RightButtonStartX + 5, RightButtonStartY + 12), c4
LINE (RightButtonStartX + 11, RightButtonStartY + 6)-(RightButtonStartX + 11, RightButtonStartY + 11), c3
LINE (RightButtonStartX + 6, RightButtonStartY + 11)-(RightButtonStartX + 11, RightButtonStartY + 11), c3
LINE (RightButtonStartX + 5, RightButtonStartY + 9)-(RightButtonStartX + 5, RightButtonStartY + 11), c1
LINE (RightButtonStartX + 6, RightButtonStartY + 9)-(RightButtonStartX + 6, RightButtonStartY + 10), c1
PSET (RightButtonStartX + 7, RightButtonStartY + 9), c1
LINE (RightButtonStartX + 9, RightButtonStartY + 5)-(RightButtonStartX + 11, RightButtonStartY + 5), c1
LINE (RightButtonStartX + 9, RightButtonStartY + 6)-(RightButtonStartX + 10, RightButtonStartY + 6), c1
PSET (RightButtonStartX + 9, RightButtonStartY + 7), c1
LINE (RightButtonStartX + 10, RightButtonStartY + 9)-(RightButtonStartX + 10, RightButtonStartY + 10), c2
PSET (RightButtonStartX + 9, RightButtonStartY + 10), c2
LINE (RightButtonStartX + 10, RightButtonStartY + 8)-(RightButtonStartX + 8, RightButtonStartY + 10), c1
LINE (RightButtonStartX + 10, RightButtonStartY + 7)-(RightButtonStartX + 7, RightButtonStartY + 10), c2
LINE (RightButtonStartX + 2, RightButtonStartY + 2)-(RightButtonStartX + 4, RightButtonStartY + 2), c1
LINE (RightButtonStartX + 2, RightButtonStartY + 3)-(RightButtonStartX + 3, RightButtonStartY + 3), c1
PSET (RightButtonStartX + 2, RightButtonStartY + 4), c1
LINE (RightButtonStartX + 6, RightButtonStartY + 2)-(RightButtonStartX + 6, RightButtonStartY + 4), c2
LINE (RightButtonStartX + 2, RightButtonStartY + 6)-(RightButtonStartX + 3, RightButtonStartY + 6), c2
LINE (RightButtonStartX + 5, RightButtonStartY + 2)-(RightButtonStartX + 2, RightButtonStartY + 5), c2
LINE (RightButtonStartX + 5, RightButtonStartY + 3)-(RightButtonStartX + 3, RightButtonStartY + 5), c1
LINE (RightButtonStartX + 4, RightButtonStartY + 6)-(RightButtonStartX + 6, RightButtonStartY + 6), c3
PSET (RightButtonStartX + 6, RightButtonStartY + 5), c3
LINE (RightButtonStartX + 4, RightButtonStartY + 5)-(RightButtonStartX + 5, RightButtonStartY + 5), c2
PSET (RightButtonStartX + 5, RightButtonStartY + 4), c2
'line (tabw-(3*winBarH\4)+7, (winBarH-8)\2+3)-step
COLOR _RGB(0, 0, 0), c2
_PRINTSTRING (winBarH * 2, 6), ss$
'''
'line (winBarH*2, 0)-step(len(s$)*8,winBarH),_rgb(255,255,0),b
'_printstring (winBarH*2, 5), ss$
's$ = left$(win(id).cap, win(id).w\8 - 3)
'_printstring (4, 3), s$
'line (0, winBarH) - step(win(id).w, 0), _rgb(255,255,255)
'line (win(id).w - winBarH+3, 3)-step(winBarH-6,winBarH-6), _rgb(255,255,255), b
SELECT CASE win(id).pid
CASE 1
LINE (4, winBarH + 4)-(win(id).w - 4, win(id).h - 4), _RGB(255, 255, 255), BF
COLOR _RGB(0, 0, 0), _RGB(255, 255, 255)
CASE 2
LINE (4, winBarH + 4)-(win(id).w - 4, win(id).h - 4), _RGB(0, 0, 0), BF
COLOR _RGB(0, 255, 0), _RGB(0, 0, 0)
END SELECT
SELECT CASE win(id).pid
CASE 0
LINE (4, winBarH + 4)-(win(id).w - 4, win(id).h - 4), _RGB(156, 156, 156), BF
COLOR _RGB(0, 0, 0), _RGB(156, 156, 156)
_PRINTSTRING ((win(id).w - 3 * 8) \ 2, (win(id).h - 2 * fontSize) \ 2), "vwm"
_PRINTSTRING ((win(id).w - 9 * 8) \ 2, (win(id).h - 2 * fontSize) \ 2 + 16), "version 2"
CASE 1 TO 2
DIM temp AS _MEM
temp = win(id).text.cur
maxy = (win(id).h - winBarH + 8) \ fontSize - 1
FOR i = win(id).text.cy TO maxy
IF temp.OFFSET = win(id).text.tail.OFFSET THEN EXIT FOR
_PRINTSTRING (4, winBarH + 4 + i * fontSize), readNode$(temp)
nextNode temp, temp
NEXT
temp = win(id).text.cur
IF win(id).text.cy > 0 THEN
FOR i = win(id).text.cy - 1 TO 0 STEP -1
prevNode temp, temp
IF temp.OFFSET = win(id).text.head.OFFSET THEN EXIT FOR
_PRINTSTRING (4, winBarH + 4 + i * fontSize), readNode$(temp)
NEXT
END IF
LINE (4 + 8 * win(id).text.cx, winBarH + 4 + fontSize * win(id).text.cy)-STEP(8, fontSize), , B
END SELECT
_DEST 0
END SUB
SUB drawBox (boxx, boxy, boxw, boxh)
w3 = boxw \ 3
h3 = (boxh - winBarH) \ 3
DIM c AS LONG
c = _RGB(255, 0, 255)
LINE (boxx, boxy)-STEP(boxw, boxh), c, B
LINE (boxx, boxy + winBarH)-STEP(boxw, 0), c
LINE (boxx + w3, boxy + winBarH)-STEP(0, boxh - winBarH), c, B
LINE (boxx + 2 * w3, boxy + winBarH)-STEP(0, boxh - winBarH), c, B
LINE (boxx, boxy + h3 + winBarH)-STEP(boxw, 0), c, B
LINE (boxx, boxy + 2 * h3 + winBarH)-STEP(boxw, 0), c, B
END SUB
FUNCTION mbox (x, y, w, h)
IF mx >= x THEN
IF my >= y THEN
IF mx <= x + w THEN
IF my <= y + h THEN
mbox = -1
EXIT FUNCTION
END IF
END IF
END IF
END IF
mbox = 0
END FUNCTION
SUB addNodeNext (new AS _MEM, s$, cur AS _MEM, list1 AS listType)
DIM node AS nodeType
DIM temp AS _MEM
DIM n AS _MEM
list1.scrollmax = list1.scrollmax + 1
temp = _MEMNEW(LEN(node))
nextNode n, cur
node.strLen = LEN(s$)
IF node.strLen > 0 THEN
node.str = _MEMNEW(LEN(s$))
_MEMPUT node.str, node.str.OFFSET, s$
END IF
node.n = n
node.p = cur
_MEMPUT temp, temp.OFFSET, node
node = _MEMGET(cur, cur.OFFSET, nodeType)
node.n = temp
_MEMPUT cur, cur.OFFSET, node
node = _MEMGET(n, n.OFFSET, nodeType)
node.p = temp
_MEMPUT n, n.OFFSET, node
new = temp
END SUB
SUB addNodePrev (new AS _MEM, s$, cur AS _MEM, list1 AS listType)
DIM node AS nodeType
DIM temp AS _MEM
DIM p AS _MEM
list1.scrollmax = list1.scrollmax + 1
temp = _MEMNEW(LEN(node))
prevNode p, cur
node.strLen = LEN(s$)
IF node.strLen > 0 THEN
node.str = _MEMNEW(LEN(s$))
_MEMPUT node.str, node.str.OFFSET, s$
END IF
node.n = cur
node.p = p
_MEMPUT temp, temp.OFFSET, node
node = _MEMGET(cur, cur.OFFSET, nodeType)
node.p = temp
_MEMPUT cur, cur.OFFSET, node
node = _MEMGET(p, p.OFFSET, nodeType)
node.n = temp
_MEMPUT p, p.OFFSET, node
new = temp
END SUB
SUB rmNode (cur AS _MEM, list1 AS listType)
DIM node AS nodeType
DIM n AS _MEM
DIM p AS _MEM
list1.scrollmax = list1.scrollmax - 1
'remove the string first
node = _MEMGET(cur, cur.OFFSET, nodeType)
IF node.strLen > 0 THEN
_MEMFREE node.str
END IF
nextNode n, cur
prevNode p, cur
node = _MEMGET(p, p.OFFSET, nodeType)
node.n = n
_MEMPUT p, p.OFFSET, node
node = _MEMGET(n, n.OFFSET, nodeType)
node.p = p
_MEMPUT n, n.OFFSET, node
_MEMFREE cur
END SUB
SUB nextNode (new AS _MEM, old AS _MEM)
DIM node AS nodeType
node = _MEMGET(old, old.OFFSET, nodeType)
new = node.n
END SUB
SUB prevNode (new AS _MEM, old AS _MEM)
DIM node AS nodeType
node = _MEMGET(old, old.OFFSET, nodeType)
new = node.p
END SUB
FUNCTION lenNode (cur AS _MEM)
DIM node AS nodeType
node = _MEMGET(cur, cur.OFFSET, nodeType)
lenNode = node.strLen
END FUNCTION
FUNCTION readNode$ (cur AS _MEM)
DIM node AS nodeType
node = _MEMGET(cur, cur.OFFSET, nodeType)
IF node.strLen = 0 THEN
readNode$ = ""
EXIT FUNCTION
END IF
s$ = STRING$(node.strLen, 0)
_MEMGET node.str, node.str.OFFSET, s$
readNode$ = s$
END SUB
SUB writeNode (cur AS _MEM, s$)
DIM node AS nodeType
'remove old string, free memory
node = _MEMGET(cur, cur.OFFSET, nodeType)
IF node.strLen > 0 THEN _MEMFREE node.str
'add new string
node.strLen = LEN(s$)
IF node.strLen > 0 THEN
node.str = _MEMNEW(LEN(s$))
_MEMPUT node.str, node.str.OFFSET, s$
END IF
_MEMPUT cur, cur.OFFSET, node
END SUB
SUB newList (new AS listType)
DIM node AS nodeType
new.head = _MEMNEW(LEN(node))
new.tail = _MEMNEW(LEN(node))
new.cx = 0
new.cy = 0
new.scroll = 0
new.scrollmax = 0
s$ = "head"
node.strLen = LEN(s$)
node.str = _MEMNEW(LEN(s$))
node.n = new.tail
node.p = new.tail
_MEMPUT node.str, node.str.OFFSET, s$
_MEMPUT new.head, new.head.OFFSET, node
s$ = "tail"
node.strLen = LEN(s$)
node.str = _MEMNEW(LEN(s$))
node.n = new.head
node.p = new.head
_MEMPUT node.str, node.str.OFFSET, s$
_MEMPUT new.tail, new.tail.OFFSET, node
END SUB
SUB printList (cur AS listType)
DIM temp AS _MEM
nextNode temp, cur.head
DO
IF temp.OFFSET = cur.tail.OFFSET THEN EXIT DO
PRINT readNode$(temp)
nextNode temp, temp
LOOP
END SUB
SUB rmList (cur AS listType)
DIM temp AS _MEM
DIM temp2 AS _MEM
nextNode temp, cur.head
DO
IF temp.OFFSET = cur.tail.OFFSET THEN EXIT DO
temp2 = temp
nextNode temp, temp2
rmNode temp2, cur
LOOP
rmNode cur.head, cur
rmNode cur.tail, cur
END SUBRE: Vince's Corner Takeout - bplus - 08-19-2022
Pretty nice the text boxes scroll with wheel and do more than one page.
Thumbs up! It's better than what I've come up with so far.
RE: Vince's Corner Takeout - vince - 08-23-2022
Complex Number Library
This is a work in progress collection of operators and functions for complex numbers. Mostly in the form of SUBs and FUNCTIONs at the end of the code. The demo shows the library in use in several complex number topics with domain coloring plots as well as a simple example of how to plot the Mandelbrot set at the end.
Code: (Select All)
defdbl a-z
const sw = 800
const sh = 600
dim shared pi
pi = 4*atn(1)
zoom = 140
dim as long i, j, k, xx, yy
screen _newimage(sw, sh, 32)
for i=0 to 9
'''plots
for yy=0 to sh
for xx=0 to sw
x = (xx - sw/2)/zoom
y = (sh/2 - yy)/zoom
select case i
case 0
u = x
v = y
pset (xx, yy), hrgb(u, v)
case 1
u = x
v = y
pset (xx, yy), checker(u, v)
case 2
'w = 1/z
cdiv u, v, 1, 0, x, y
'pset (xx, yy), hrgb(u, v)
pset (xx, yy), checker(u, v)
case 3
'w = sin(1/z)
'extra zoom
d = 0.35*(x*x + y*y)
if d<>0 then
u = sin(x/d)*cosh(-y/d)
v = cos(x/d)*sinh(-y/d)
else
u = 0
v = 0
end if
pset (xx, yy), hrgb(u, v)
'pset (xx, yy), checker(u, v)
case 4
'extra zoom
u = 0.56*x
v = 0.56*y
for j=0 to 14
uu = u*u - v*v + 0.35
vv = 2*u*v + 0.0
u = uu
v = vv
next
pset (xx, yy), hrgb(u, v)
'pset (xx, yy), checker(u, v)
case 5
cmul u, v, 1, 0, x - cos(2*pi/3), y + sin(2*pi/3)
cmul u, v, u, v, x - cos(2*pi/3), y - sin(2*pi/3)
cmul u, v, u, v, x - 1, y
'cdiv u, v, u, v, x - 1, y
pset (xx, yy), hrgb(u, v)
'pset (xx, yy), checker(u, v)
case 6
'CIF numerical integration
'f(z_0) = (2 pi i)^-1 int_C f(z)/(z - z0) dz
n = 35
uu = 0
vv = 0
for j=0 to n - 1
'C: z(t)
p = 1.5*cos(j*2*pi/n)
q = 1.5*sin(j*2*pi/n)
'f(z(t)):
cmul u, v, 1, 0, p - cos(2*pi/3), q + sin(2*pi/3)
cmul u, v, u, v, p - cos(2*pi/3), q - sin(2*pi/3)
cmul u, v, u, v, p - 1, q
'f(z)/(z - z0)
cdiv u, v, u, v, p - x, q - y
'dz/dt
cmul u, v, u, v, -1.5*sin(j*2*pi/n), 1.5*cos(j*2*pi/n)
if j = 0 or j = n - 1 then
uu = uu + 0.5*u
vv = vv + 0.5*v
else
uu = uu + u
vv = vv + v
end if
next
'dt
u = uu*2*pi/n
v = vv*2*pi/n
'1/(2 pi i)
cmul u, v, u, v, 0, -1/(2*pi)
pset (xx, yy), hrgb(u, v)
'pset (xx, yy), checker(u, v)
case 7
'extra zoom
x = x*0.5
y = y*0.5
p = 1
q = 0
for j=0 to 5
cmul uu, vv, 1, 0, -0.4, -0.18*(j - 2.1)
cmul p, q, p, q, x - uu - 0.2, y - vv
cdiv p, q, p, q, x - uu + 0.2, y - vv + 0.1
next
for j=0 to 2
cmul uu, vv, 1, 0, 0.4, -0.18*(j - 2.1) - 0.18*2.1/2
cdiv p, q, p, q, x - uu - 0.2, y - vv
cmul p, q, p, q, x - uu + 0.2, y - vv + 0.1
next
u = p
v = q
pset (xx, yy), grey(u, v)
case 8
'extra zoom
u = 0.66*x - 0.5
v = 0.66*y
x0 = u
y0 = v
for j=0 to 3
uu = u*u - v*v + x0
vv = 2*u*v + y0
u = uu
v = vv
next
'pset (xx, yy), hrgb(u, v)
pset (xx, yy), checker(u, v)
case 9
'extra zoom
u = 0.66*x - 0.5
v = 0.66*y
x0 = u
y0 = v
for j=0 to 70
uu = u*u - v*v + x0
vv = 2*u*v + y0
u = uu
v = vv
next
'pset (xx, yy), hrgb(u, v)
pset (xx, yy), checker(u, v)
end select
next
next
'''diagrams
select case i
case 0
_title "w = z polar contouring"
case 1
_title "w = z checkerboard"
case 2
_title "w = 1/z singularity"
case 3
_title "w = sin(1/z) essential singularity"
case 4
_title "Julia fractal"
case 5
_title "tri mass"
case 6
_title "Cauchy integral formula"
a = 0
x = 1.5*cos(a)
y = 1.5*sin(a)
circle (x*zoom + sw/2, sh/2 - y*zoom), 3, _rgb(255,255,0)
for a=0 to 2*pi step 2*pi/n
x = 1.5*cos(a)
y = 1.5*sin(a)
line -(x*zoom + sw/2, sh/2 - y*zoom), _rgb(255,255,0)
circle step(0,0), 3, _rgb(255,255,0)
next
case 7
_title "mutual inductance"
sleep
'extra zoom
m = zoom/0.5
'this diagram is a JB original
'left
a = -pi/2
x = sw/2/m + 0.2*cos(a) - 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5/pi) - 2.1*0.18
for t=x to 0 step -0.001
circlef (x - t)*m, y*m, 1, _rgb(0,0,0)
next
for a = -pi/2 to 5*2*pi + 2*pi + pi/2 step 0.01
x = sw/2/m + 0.2*cos(a) - 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5/pi) - 2.1*0.18
circlef x*m, y*m, 1, _rgb(0,0,0)
next
a = 5*2*pi + 2*pi + pi/2
x = sw/2/m + 0.2*cos(a) - 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5/pi) - 2.1*0.18
for t=x to 0 step -0.001
circlef (x - t)*m, y*m, 1, _rgb(0,0,0)
next
'right
a = -pi/2
x = sw/2/m - 0.2*cos(a) + 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5)/pi - 2.1*0.18 + 0.18*2.1/4
for t=0 to 1.5 step 0.001
circlef (x + t)*m, y*m, 1, _rgb(0,0,0)
next
for a = -pi/2 to 2*2*pi + 2*pi + pi/2 step 0.01
x = sw/2/m - 0.2*cos(a) + 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5)/pi - 2.1*0.18 + 0.18*2.1/4
circlef x*m, y*m, 1, _rgb(0,0,0)
next
a = 2*2*pi + 2*pi + pi/2
x = sw/2/m - 0.2*cos(a) + 0.4
y = sh/2/m + 0.18*sin(a) + (a*0.18*0.5)/pi - 2.1*0.18 + 0.18*2.1/4
for t=0 to 1.5 step 0.001
circlef (x + t)*m, y*m, 1, _rgb(0,0,0)
next
case 8
_title "checkerboard Mandelbrot"
end select
sleep
next
_title "escape time example with nth order Mandelbrot"
zoom = 210
for n=2 to 6
'line (0, 0)-(sw, sh), _rgb(255,255,255), bf
for yy=0 to sh
for xx=0 to sw
x = (xx - sw/2)/zoom - 0.5
y = (sh/2 - yy)/zoom
u = 0
v = 0
for i=0 to 140
'f(z) = z^n + c
cexp u, v, u, v, n, 0
u = u + x
v = v + y
if u*u + v*v > 4 then exit for
next
if i>=140 then
pset (xx, yy), _rgb(0,0,0)
else
pset (xx, yy), _rgb(255,255,255)
end if
next
next
sleep
next
system
sub circlef(x as long, y as long, r as long, c as long)
dim as long x0, y0, e
x0 = r
y0 = 0
e = -r
do while y0 < x0
if e <=0 then
y0 = y0 + 1
line (x - x0, y + y0)-(x + x0, y + y0), c, bf
line (x - x0, y - y0)-(x + x0, y - y0), c, bf
e = e + 2*y0
else
line (x - y0, y - x0)-(x + y0, y - x0), c, bf
line (x - y0, y + x0)-(x + y0, y + x0), c, bf
x0 = x0 - 1
e = e - 2*x0
end if
loop
line (x - r, y)-(x + r, y), c, bf
end sub
function grey~&(x, y)
m = sqr(x*x + y*y)
a = (pi + _atan2(y, x))/(2*pi)
m = log(1 + 100*m)
'polar contouring
n = 16
mm = m*5000 mod 500
p = abs(a*n - int(a*n))
g = 1 - 0.0007*mm - 0.21*p
grey = _rgb(255*g, 255*g, 255*g)
end function
function checker~&(xx, yy)
if 1 then
x = xx
y = yy
else 'polar checkerboard
x = _atan2(yy, xx)/(pi/4)
y = sqr(xx*xx + yy*yy)
y = log(1 + 1000*y)
end if
z = abs(x - int(x)) xor abs(y - int(y))
if z then checker = _rgb(0,0,0) else checker = _rgb(255,255,255)
end function
function hrgb~&(x, y)
m = sqr(x*x + y*y)
a = (pi + _atan2(y, x))/(2*pi)
'm = log(1 + 1000*m)
r = 0.5 - 0.5*sin(2*pi*a - pi/2)
g = (0.5 + 0.5*sin(2*pi*a*1.5 - pi/2)) * -(a < 0.66)
b = (0.5 + 0.5*sin(2*pi*a*1.5 + pi/2)) * -(a > 0.33)
'polar contouring
n = 16
mm = m*500 mod 500
p = abs(a*n - int(a*n))
r = r - 0.0005*mm - 0.14*p
g = g - 0.0005*mm - 0.14*p
b = b - 0.0005*mm - 0.14*p
'cartesian shading
if 0 then
t = 0.03 'thickness
xx = abs(x - int(x)) < t or abs(-x - int(-x)) < t
yy = abs(y - int(y)) < t or abs(-y - int(-y)) < t
if xx or yy then
'if m > 1 then 'dont shade origin
r = r - 0.5
g = g - 0.5
b = b - 0.5
'end if
end if
end if
hrgb = _rgb(255*r, 255*g, 255*b)
end function
sub cmul(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb
u = x*a - y*b
v = x*b + y*a
end sub
sub cdiv(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb
d = a*a + b*b
u = (x*a + y*b)/d
v = (y*a - x*b)/d
end sub
sub cexp(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb
lnz = x*x + y*y
if lnz = 0 then
u = 0
v = 0
else
lnz = 0.5*log(lnz)
argz = _atan2(y, x)
m = exp(a*lnz - b*argz)
a = a*argz + b*lnz
u = m*cos(a)
v = m*sin(a)
end if
end sub
sub clog(u, v, xx, yy)
x = xx
y = yy
lnz = x*x + y*y
if lnz=0 then
u = 0
v = 0
else
u = 0.5*log(lnz)
v = _atan2(y, x)
end if
end sub
function cosh(x)
cosh = 0.5*(exp(x) + exp(-x))
end function
function sinh(x)
sinh = 0.5*(exp(x) - exp(-x))
end function
sub csin(u, v, xx, yy)
x = xx
y = yy
u = sin(x)*cosh(y)
v = cos(x)*sinh(y)
end sub
sub ccos(u, v, xx, yy)
x = xx
y = yy
u = cos(x)*cosh(y)
v =-sin(x)*sinh(y)
end sub
function factorial~&(n)
if n = 0 then
factorial = 1
else
factorial = n*factorial(n - 1)
end if
end functionRE: Vince's Corner Takeout - vince - 11-04-2022
Dithering with an arbitrary diffusion matrix
![[Image: 5nM20e2.png]](https://i.imgur.com/5nM20e2.png)
Code: (Select All)
deflng a-z
img1 = _loadimage("nefertiti.jpg", 32)
w = _width(img1)
h = _height(img1)
img2 = _newimage(w, h, 32)
img3 = _newimage(w, h, 32)
img4 = _newimage(w, h, 32)
img5 = _newimage(w, h, 32)
img6 = _newimage(w, h, 32)
img7 = _newimage(w, h, 32)
img8 = _newimage(w, h, 32)
img9 = _newimage(w, h, 32)
img10 = _newimage(w, h, 32)
screen _newimage(w*3, h*3, 32)
redim h(2, 1) as single
h(0,0)=0:h(1,0)=-1:h(2,0)=7/16
h(0,1)=3/16:h(1,1)=5/16:h(2,1)=1/16
dither_bw img1, img2, 0.1, h()
dither img1, img3, 2, h()
dither img1, img4, 4, h()
redim h(4, 2) as single
h(0,0)=0:h(1,0)=0:h(2,0)=-1:h(3,0)=7/48:h(4,0)=5/48
h(0,1)=3/48:h(1,1)=5/48:h(2,1)=7/48:h(3,1)=5/48:h(4,1)=3/48
h(0,2)=1/48:h(1,2)=3/48:h(2,2)=5/48:h(3,2)=3/48:h(4,2)=1/48
dither_bw img1, img5, 0.1, h()
dither img1, img6, 2, h()
dither img1, img7, 4, h()
redim h(3, 2) as single
h(0,0)=0:h(1,0)=-1:h(2,0)=1/8:h(3,0)=1/8
h(0,1)=1/8:h(1,1)=1/8:h(2,1)=1/8:h(3,1)=0
h(0,2)=0:h(1,2)=1/8:h(2,2)=0:h(3,2)=0
dither_bw img1, img8, 0.1, h()
dither img1, img9, 2, h()
dither img1, img10, 4, h()
_dest 0
_putimage (0, 0), img2
_putimage (w, 0), img3
_putimage (2*w, 0), img4
_printstring (0,0),"Floyd-Steinberg"
_putimage (0, h), img5
_putimage (w, h), img6
_putimage (2*w, h), img7
_printstring (0,h),"Jarvis, Judice, and Ninke"
_putimage (0, 2*h), img8
_putimage (w, 2*h), img9
_putimage (2*w, 2*h), img10
_printstring (0,2*h),"Atkinson"
do
loop until _keyhit=27
system
'colour dither
'source image, destination image, number of colours per channel, diffusion matrix
sub dither(img1, img2, num, h() as single)
w = _width(img1)
h = _height(img1)
_dest img2
_source img2
_putimage , img1
for y=0 to h-1
for x=0 to w-1
z = point(x, y)
r = (_red(z)*num\255)*255\num
g = (_green(z)*num\255)*255\num
b = (_blue(z)*num\255)*255\num
pset (x, y), _rgb(r, g, b)
qr = _red(z) - r
qg = _green(z) - g
qb = _blue(z) - b
conv_ed img2, x, y, h(), qr, qg, qb
next
next
end sub
'black and white dither
'source image, destination image, bw threshold percent, diffusion matrix
sub dither_bw(img1, img2, t as double, h() as single)
w = _width(img1)
h = _height(img1)
_dest img2
_source img2
_putimage , img1
for y=0 to h-1
for x=0 to w-1
z = point(x, y)
c = -((_red(z)+_green(z)+_blue(z))/3 > 255*t)*255
pset (x, y), _rgb(c, c, c)
qr = _red(z) - c
qg = _green(z) - c
qb = _blue(z) - c
conv_ed img2, x, y, h(), qr, qg, qb
next
next
end sub
sub conv_ed(img, x0, y0, h() as single, qr, qg, qb)
for y=0 to ubound(h,2)
for x=0 to ubound(h,1)
if h(x,y)=-1 then
xx = x
yy = y
end if
next
next
_source img
_dest img
for y=0 to ubound(h,2)
for x=0 to ubound(h,1)
if h(x,y) > 0 then
r = _red(point(x0-xx+x, y0-yy+y)) + qr*h(x,y)
g = _green(point(x0-xx+x, y0-yy+y)) + qg*h(x,y)
b = _blue(point(x0-xx+x, y0-yy+y)) + qb*h(x,y)
pset (x0-xx+x, y0-yy+y), _rgb(r, g, b)
end if
next
next
end subRE: Vince's Corner Takeout - vince - 03-31-2023
Software rotozoom example
Code: (Select All)
deflng a-z
'const sw = 800
'const sh = 600
dim shared pi as double
pi = 4*atn(1)
img = _loadimage("leopardx.jpg", 32)
w = _width(img)
h = _height(img)
dim zoom as double
dim a as double
zoom = 2.5
a = 2*sqr(w*w/4 + h*h/4)*zoom
if h < a then h = a
screen _newimage(w + a*2, h, 32)
_putimage (0,0), img
dim rot as double
do
rot = rot + 0.1
line (w, 0)-step(a*2, a),_rgb(0,0,0),bf
rotzoom img, w + a/2, a/2, rot, zoom
rotzoomb img, w + a + a/2, a/2, rot, zoom
_display
_limit 30
loop until _keyhit = 27
sleep
system
sub rotzoomb(img, x0, y0, rot as double, zoom as double)
dim a as double
dim xx as double, yy as double
dim dx as double, dy as double
w = _width(img)
h = _height(img)
if zoom = 0 then zoom = 1
a = 2*sqr(w*w/4 + h*h/4)*zoom
_source img
for y=0 to a
for x=0 to a
xx = (x - a/2)*cos(rot)/zoom - (y - a/2)*sin(rot)/zoom + w/2
yy = (x - a/2)*sin(rot)/zoom + (y - a/2)*cos(rot)/zoom + h/2
if (int(xx) >=0 and int(xx) < w - 1 and int(yy) >= 0 and int(yy) < h - 1) then
tl = point(int(xx), int(yy))
tr = point(int(xx) + 1, int(yy))
bl = point(int(xx), int(yy) + 1)
br = point(int(xx) + 1, int(yy) + 1)
dx = xx - int(xx)
dy = yy - int(yy)
r = _round((1 - dy)*((1 - dx)* _red(tl) + dx* _red(tr)) + dy*((1 - dx)* _red(bl) + dx* _red(br)))
g = _round((1 - dy)*((1 - dx)*_green(tl) + dx*_green(tr)) + dy*((1 - dx)*_green(bl) + dx*_green(br)))
b = _round((1 - dy)*((1 - dx)* _blue(tl) + dx* _blue(tr)) + dy*((1 - dx)* _blue(bl) + dx* _blue(br)))
pset (x0 - a/2 + x, y0 - a/2 + y), _rgb(r, g, b)
elseif (int(xx) >=0 and int(xx) < w - 1 and int(yy) >= 0 and int(yy) < h - 1) then
pset (x0 - a/2 + x, y0 - a/2 + y), point(int(xx), int(yy))
end if
next
next
end sub
sub rotzoom(img, x0, y0, rot as double, zoom as double)
dim a as double
w = _width(img)
h = _height(img)
if zoom = 0 then zoom = 1
a = 2*sqr(w*w/4 + h*h/4)*zoom
_source img
for y=0 to a
for x=0 to a
xx = (x - a/2)*cos(rot)/zoom - (y - a/2)*sin(rot)/zoom + w/2
yy = (x - a/2)*sin(rot)/zoom + (y - a/2)*cos(rot)/zoom + h/2
if ((xx) >= 0 and (xx) < w and (yy) >=0 and (yy) < h) then
pset (x0 - a/2 + x, y0 - a/2 + y), point(int(xx), int(yy))
end if
next
next
end subRE: Vince's Corner Takeout - vince - 09-18-2023
classic starscape mod
Code: (Select All)
randomize timer
dim shared pi, d, zz, sw, sh
pi = 4*atn(1)
d = 700
zz = 2100
sw = 1280
sh = 720
type stype
x as double
y as double
z as double
end type
dim shared star(2000) as stype
type gtype
x as double
y as double
z as double
r as double
r1 as double
r2 as double
a1 as double
a2 as double
a3 as double
end type
dim shared galaxy(100) as gtype
screen _newimage(sw, sh, 32)
for i=0 to 2000
star(i).x = 5000*rnd-2500
star(i).y = 5000*rnd-2500
star(i).z = 5000*rnd-2500
next
for i=0 to 30
galaxy(i).x = 4000*rnd-2000
galaxy(i).y = 4000*rnd-2000
galaxy(i).z = 4000*rnd-2000
galaxy(i).r = 150*rnd
galaxy(i).r1 = rnd
galaxy(i).r2 = rnd
galaxy(i).a1 = 2*pi*rnd
galaxy(i).a2 = 2*pi*rnd
galaxy(i).a3 = 4*pi*rnd - 2.5*pi*rnd
next
do
cls
for i=0 to 2000
star(i).z = star(i).z - 100
if star(i).z < 0 then
star(i).x = 4000*rnd-2000
star(i).y = 4000*rnd-2000
star(i).z = 4000*rnd-2000
end if
x1 = star(i).x
y1 = star(i).y
z1 = star(i).z
for z0 = 0 to 3
pset (sw/2 + x1*d/(z1 + zz + z0*10), sh/2 - y1*d/(z1 + zz + z0*10)),_rgb(255 - 50*z0, 255 - 50*z0, 0)
next
next
for i=0 to 30
galaxy(i).z = galaxy(i).z - 100
if galaxy(i).z < -zz then
galaxy(i).x = 4000*rnd-2000
galaxy(i).y = 4000*rnd-2000
galaxy(i).z = 8000*rnd'-2000
galaxy(i).r = 10*rnd + 30
galaxy(i).r1 = rnd
galaxy(i).r2 = rnd
galaxy(i).a1 = 2*pi*rnd
galaxy(i).a2 = 2*pi*rnd
galaxy(i).a3 = 4*pi*rnd - 2.5*pi*rnd
end if
x1 = galaxy(i).x
y1 = galaxy(i).y
z1 = galaxy(i).z
r = galaxy(i).r
r1 = galaxy(i).r1
r2 = galaxy(i).r2
a1 = galaxy(i).a1
a2 = galaxy(i).a2
a3 = galaxy(i).a3
drawgalaxy x1, y1, z1, r, r1, r2, a1, a2, a3
next
_display
_limit 30
loop until _keyhit = 27
sleep
system
sub drawgalaxy(x1, y1, z1, r, r1, r2, a1, a2, u)
dim c as _unsigned long
for a=0 to u step 0.1
for i=0 to 0.001*r*(u - a)^3.5
x0 = (rnd - 0.5)*0.2*r*(u - a)
y0 = (rnd - 0.5)*0.2*r*(u - a)
z0 = (rnd - 0.5)*0.2*r*(u - a)
if x0*x0 + y0*y0 + z0*z0 < 2000 then
for k=0 to 1
x = x0 + r1*r*a*cos(a + k*pi)
y = y0 + r2*r*a*sin(a + k*pi)
z = z0 + 1
rot x, y, a1
rot y, z, a2
c = 255*(u - a)/2
rr = c + rnd*50
gg = 0.2*c + rnd*50
bb = 0
if rr < 0 then rr = 0
if gg < 0 then gg = 0
if bb < 0 then bb = 0
if rr > 255 then rr = 255
if gg > 255 then gg = 255
if bb > 255 then bb = 255
rr = rr - z1/100
gg = gg - z1/100
bb = bb - z1/100
pset (sw/2 + (x + x1)*d/(z + z1 + zz), sh/2 - (y + y1)*d/(z + z1 + zz)), _rgb(rr, gg, bb)
next
end if
next
next
end sub
sub rot(xx, yy, a)
x = xx
y = yy
xx = x*cos(a) - y*sin(a)
yy = x*sin(a) + y*cos(a)
end subRE: Vince's Corner Takeout - Dav - 09-19-2023
Cool one!
- Dav
RE: Vince's Corner Takeout - bplus - 09-19-2023
(09-19-2023, 12:54 AM)Dav Wrote: Cool one!
- Dav
Yeah, I think dbox was showing this or something like this.
Update: ah, his was like slideshow, not animated.
RE: Vince's Corner Takeout - GareBear - 09-19-2023
Vince, This is nice animation. Liked it very well.
RE: Vince's Corner Takeout - bplus - 09-19-2023
(09-19-2023, 03:56 PM)GareBear Wrote: Vince, This is nice animation. Liked it very well.
If you like give him a rep point, we want to encourage him to do more.
@GareBear looks like you could use some too, post some stuff, I bet I will like it too!
If you think 'I am only a beginner' then there is this:
https://qb64phoenix.com/forum/showthread.php?tid=1693&pid=16026#pid16026
for beginners to ask or show off