Pic maker

[Pyrokid]

I am working on a picture maker for my games so i dont have write them all out into a data segment so here it is tell me what you think


In the reader you move with the arrow keys and select colors with the numberpad. press "s" to get to the save pic sub then when you have selected your pic within the lines press tab to save it

Code:

DECLARE SUB savepic ()
DECLARE SUB save ()
up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80): lft$ = CHR$(0) + CHR$(75)
rght$ = CHR$(0) + CHR$(77)
DIM SHARED prev(1000)
DIM SHARED x
DIM SHARED y
DIM SHARED sx
DIM SHARED sy
DIM SHARED zoom
DIM SHARED col(150, 107)
x = 1: y = 1
sx = 1: sy = 1

1
CLS
COLOR 11: PRINT "Picture Maker"
COLOR 12: PRINT "1) Get started"
COLOR 13: PRINT "2) Controls"
COLOR 14: PRINT "3) Quit"
COLOR 7
a$ = "0"
DO UNTIL VAL(a$) <= 3 AND VAL(a$) >= 1: a$ = INKEY$: LOOP
SELECT CASE VAL(a$)
  CASE 1
  GOTO prompt
  CASE 2
  GOTO controls
  CASE 3
  END
END SELECT

controls:
PRINT "Controls"
PRINT "Arrow keys to move cursor:"
PRINT "Numbers to change colors"
PRINT "S to save"
PRINT "When in save press S at any time to exit to edit mode"
PRINT "When in save select the part in the picture that you want to save"
PRINT "then press tab and it will give the x and y lengths, save them for the reader"
SLEEP
GOTO 1



prompt:
INPUT "Select the zoom of the picture (0-10)", zoom


CLS
SCREEN 13

GET (0, 0)-(4, 4), prev

color1 = 0

DO
a$ = INKEY$
IF a$ = CHR$(27) THEN END
IF color1 = 0 THEN color1 = 11
LINE (x, y)-(x + zoom, y + zoom), color1, BF




SELECT CASE UCASE$(a$)


  CASE "S"
  save

  'checks for up down left or right
  CASE up$
  IF y > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  y = y - (zoom + 1)
  sy = sy - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE down$
  IF y <= 144 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sy = sy + 1
  y = y + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE rght$
  IF x <= 314 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sx = sx + 1
  x = x + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE lft$
  IF x > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  x = x - (zoom + 1)
  sx = sx - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF

  'clears blocks
  CASE "C"
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  col(sx, sy) = 0
  GET (x, y)-(x + zoom, y + zoom), prev
END SELECT

'changes colors of blocks
IF VAL(a$) <= 9 AND VAL(a$) >= 1 THEN
  b = VAL(a$)
  color1 = b
  col(sx, sy) = b
  LINE (x, y)-(x + zoom, y + zoom), b, BF
  GET (x, y)-(x + zoom, y + zoom), prev
END IF


LOOP

SUB save
up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80): lft$ = CHR$(0) + CHR$(75)
rght$ = CHR$(0) + CHR$(77)
DIM prevy(16383)
DIM prevx(16383)
GET (0, y)-(x, y), prevy
GET (x, 0)-(x, y), prevx

DO
a$ = INKEY$
color2 = 11
LINE (x, y)-(x + zoom, y + zoom), color2, BF
'draws a straight line from the wall to the block so the user
'knows what he is saving
LINE (0, y)-(x, y), 9
LINE (x, 0)-(x, y), 9


SELECT CASE UCASE$(a$)
  'gets rid of lines and exits sub
  CASE "S"
  LINE (0, y)-(x, y), 0
  PUT (0, y), prevy
  LINE (x, 0)-(x, y), 0
  PUT (x, 0), prevx
  EXIT SUB

  'checks witch direction then clears the line
  'puts back what was there and moves the cursor
  CASE up$
  IF y >= 1 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sy = sy - 1
  y = y - (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE down$
  IF y <= 294 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sy = sy + 1
  y = y + (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE rght$
  IF x <= 314 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sx = sx + 1
  x = x + (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE lft$
  IF x >= 1 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sx = sx - 1
  x = x - (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE CHR$(9)
  savepic
END SELECT
LOOP

END SUB

SUB savepic
cx = sx
cy = sy
OPEN "pic.bmp" FOR OUTPUT AS #1
FOR cy = 1 TO sy
FOR cx = 1 TO sx
WRITE #1, col(cx, cy)
NEXT
NEXT
CLOSE #1
CLS
SCREEN 1
PRINT "x="; sx
PRINT "y="; sy
END
END SUB

After this one is done you get the x and y limits maker sure to remember these cause you need them for the reader

Code:

DECLARE SUB bmread (lx!, ly!, filename$, mul!)
CLS
SCREEN 13
INPUT "X limitations:", lx
INPUT "Y limitations:", ly
bmread lx, ly, "pic.bmp", 15

SUB bmread (lx, ly, filename$, mul)
CLS
DIM col(lx, ly)
OPEN filename$ FOR INPUT AS #1
FOR y = 1 TO ly
FOR x = 1 TO lx
INPUT #1, col(x, y)
NEXT
NEXT
CLOSE #1
ax = 0
ay = 0
FOR y = 1 TO ly * mul STEP mul
ay = ay + 1
ax = 0
FOR x = 1 TO lx * mul STEP mul
ax = ax + 1
LINE (x, y)-(x + mul, y + mul), col(ax, ay), BF
NEXT
NEXT

END SUB
[/code]

[TheDarkJay]

Not bad, include mouse support and it would be PERFECT.

[Pyrokid]

Yeah, but i dont quite get how to get the mouse to work otherwise it wolud be nice

[momoguru]

goto my site and download QBSPRITE. its a mouse driven sprite editor i made that might give you some ideas how it all works.

[Pyrokid]

I dont suppose you could direct me in the direction of a good tut on mouse (not the one at qbasicnews.com cause it sucks, no offence to the person who wrote it but it does suck)

[TheDarkJay]

FB makes using the mouse a lot simpler.

Code:

CONST LEFTBUTTON   = 1 ' sets so left mouse button works
CONST MIDDLEBUTTON = 4 ' sets so middle mouse button works
CONST RIGHTBUTTON  = 2 ' sets so right mouse button works
CONST SHOWMOUSE    = 1 ' sets so mouse arrow is visible
CONST HIDEMOUSE    = 0 ' sets so mouse arrow is visible
DIM currentx     AS INTEGER
DIM currenty     AS INTEGER
DIM mousebuttons AS INTEGER

This sets everything so the mouse can be used

Code:

GETMOUSE currentx, currenty, ,mousebuttons

and use this in the main loop so it works fine, checking the mouse buttons and such.

[Pyrokid]

Yeah but i write in QB cause i dont like FB hence the name of the forum QB Projects

[TheDarkJay]

Soz for the double post but

If you could port your save and save pic to FB i could make you a mouse driven one, i already have the engine for it, i just need the save fuction to work...

this is what i have so far \/ \/

Code:

'set mouse
CONST LEFTBUTTON   = 1 ' sets so left mouse button works
CONST MIDDLEBUTTON = 4 ' sets so middle mouse button works
CONST RIGHTBUTTON  = 2 ' sets so right mouse button works
CONST SHOWMOUSE    = 1 ' sets so mouse arrow is visible
CONST HIDEMOUSE    = 0 ' sets so mouse arrow is visible
DIM currentx     AS INTEGER
DIM currenty     AS INTEGER
DIM mousebuttons AS INTEGER

SCREEN 18

INPUT "What zoom do you want(0-10)?"; zoom
INPUT "Enter the minimum x co-ordinate"; x1
INPUT "Enter the maximum x co-ordinate"; x2
INPUT "Enter the minimum y co-ordinate"; y1
INPUT "Enter the maximum y co-ordinate"; y2

arraysize = x2 * y2 / 2 + 1
DIM save%(arraysize)
IF zoom > 10 THEN zoom = 10
IF zoom < 0 THEN zoom = 0

Cls

colour = 0
DO
  
  
k$ = InKey$

GETMOUSE currentx, currenty, ,mousebuttons

LINE (1,10)-(10, 20), 16, B
PAINT (6, 16), colour, 16
LINE (x1, y1)- (x2, y2), 15, B

IF mousebuttons = LEFTBUTTON AND currenty > y1 AND currenty < y2 AND currentx > x1 AND currentx < x2 THEN
LINE (currentx, currenty)-(currentx + zoom, currenty + zoom), colour, BF
END IF

IF k$ = "+" AND colour < 15 OR k$ = "=" AND colour < 15 THEN colour = colour + 1
IF k$ = "-" AND colour > 0 THEN colour = colour - 1
IF k$ = "x" AND zoom > 0 THEN zoom = zoom - 1
IF k$ = "z" AND zoom < 10 THEN zoom = zoom + 1

IF k$ = "s" THEN
CLS
GET (x1,y1)-(x2,y2), save%(0)
BsaveSize = x2 * y2 + 4  
BSAVE "image.gfx", VARPTR(save%(0)), bsavesize
END
END IF

LOOP UNTIL k$ = " "

[Pyrokid]

well ok i put the mouse in there it just took me a little while.
its a bit jumpy but it'tl work. also i impliment the load function with the editor so no need for 2 programs or having to save the x and y values it puts those in the .pic it creates.

*note* When saving do not put a .pic at the end of it it does it by itself if you do put one on there your pic will be destroyed.

a library is used so open your qb with a " /L" at the end of the command line

Code:

DECLARE SUB mouse ()
'$INCLUDE: 'qb.bi'
DECLARE SUB load (filename$)
DECLARE SUB savepic ()
DECLARE SUB save ()
up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80): lft$ = CHR$(0) + CHR$(75)
rght$ = CHR$(0) + CHR$(77)
ON ERROR GOTO errorhandler
DIM SHARED in AS regtypex, outr AS regtypex
DIM SHARED prev(1000)
DIM SHARED x
DIM SHARED y
DIM SHARED sx
DIM SHARED sy
DIM SHARED zoom
DIM SHARED errorcode
DIM SHARED col(150, 107)
x = 1: y = 1
sx = 1: sy = 1
1
SCREEN 13
in.ax = 0: mouse


CLS
COLOR 10: PRINT "Picture Maker"
COLOR 11: PRINT "1) Get started"
COLOR 12: PRINT "2) Controls"
COLOR 13: PRINT "3) Load"
COLOR 14: PRINT "4) Quit"
COLOR 7

a$ = "0"

DO UNTIL VAL(a$) <= 4 AND VAL(a$) >= 1: a$ = INKEY$: LOOP
SELECT CASE VAL(a$)
  CASE 1
  GOTO prompt
  CASE 2
  GOTO controls
  CASE 3
  GOTO loadpic
  CASE 4
  END
END SELECT

controls:
PRINT "Controls:"
PRINT "Arrow keys to move cursor"
PRINT "Press the numbers to change colors"
PRINT "Press S to go to the save prompt"
PRINT "When in save press S at any time to exit to edit mode"
PRINT "When in save select the part in the picture that you want to save"
PRINT "then press tab to save type a file name to save it"
SLEEP
GOTO 1



prompt:
INPUT "Select the zoom of the picture (0-10) ", zoom
INPUT "Set the mouse speed (10 slow - 0 fast) ", mspeed
CLS
GOTO start


loadpic:
INPUT "What is the name of the file? ", filename$
INPUT "What zoom would you like? ", zoom
IF zoom = 0 THEN zoom = 1
filename$ = filename$ + ".pic"
load filename$
zoom = zoom - 1
IF errorcode = 64 OR errorcode = 53 THEN GOTO 1
INPUT "Set the mouse speed (10 slow - 0 fast) ", mspeed

start:


GET (x, y)-(x + zoom, y + zoom), prev

color1 = 0
in.ax = 3: mouse
oldx = outr.cx
oldy = outr.dx

' set mouse pos at 1,1
in.ax = 4
in.cx = 1
in.dx = 1: mouse
'in.ax = 1: mouse

DO
'if the mouse is all the way to the right bring it back to 1
in.ax = 3: mouse

IF outr.cx >= 639 THEN
in.ax = 4: in.cx = 1: mouse
oldx = in.cx
END IF

'if the mouse is at the bottom bring it to the top
IF outr.dx >= 199 THEN
in.ax = 4: in.dx = 1: mouse
oldy = in.dx
END IF

'if its <= 1 then move it back to the right
IF outr.cx <= 1 THEN
in.ax = 4: in.cx = 600: mouse
oldx = in.cx
END IF

IF outr.dx <= 5 THEN
in.ax = 4: in.dx = 170: mouse
oldy = in.dx
END IF

a$ = INKEY$
IF a$ = CHR$(27) THEN END
IF color1 = 0 THEN color1 = 11
LINE (x, y)-(x + zoom, y + zoom), color1, BF



SELECT CASE UCASE$(a$)


  CASE "S"
  save

  'checks for up down left or right
  CASE up$
  IF y > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  y = y - (zoom + 1)
  sy = sy - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE down$
  IF y <= 144 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sy = sy + 1
  y = y + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE rght$
  IF x <= 314 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sx = sx + 1
  x = x + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE lft$
  IF x > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  x = x - (zoom + 1)
  sx = sx - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF

  'clears blocks
  CASE "C"
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  col(sx, sy) = 0
  GET (x, y)-(x + zoom, y + zoom), prev
END SELECT

'changes colors of blocks
IF VAL(a$) <= 9 AND VAL(a$) >= 1 THEN
  b = VAL(a$)
  color1 = b
  col(sx, sy) = b
  LINE (x, y)-(x + zoom, y + zoom), b, BF
  GET (x, y)-(x + zoom, y + zoom), prev
END IF


in.ax = 3: mouse

IF outr.cx > oldx + mspeed THEN
  IF x <= 314 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sx = sx + 1
  x = x + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  oldx = outr.cx
  END IF
END IF

IF outr.cx < oldx - mspeed THEN
  IF x > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  x = x - (zoom + 1)
  sx = sx - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  oldx = outr.cx
  END IF
END IF

IF outr.dx > oldy + mspeed THEN
  IF y <= 144 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  sy = sy + 1
  y = y + (zoom + 1)
  GET (x, y)-(x + zoom, y + zoom), prev
  oldy = outr.dx
  END IF
END IF

IF outr.dx < oldy - mspeed THEN
  IF y > 1 THEN
  color1 = 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (x, y), prev
  y = y - (zoom + 1)
  sy = sy - 1
  GET (x, y)-(x + zoom, y + zoom), prev
  oldy = outr.dx
  END IF
END IF

LOOP
END

errorhandler:
errorcode = ERR
RESUME NEXT

SUB load (filename$)
CLS
errorcode = 0

OPEN filename$ FOR INPUT AS #1

IF errorcode = 64 OR errorcode = 53 THEN
PRINT "Bad file name"
SLEEP
EXIT SUB
END IF

INPUT #1, lx, ly
FOR sy = 1 TO ly
FOR sx = 1 TO lx
INPUT #1, col(sx, sy)
NEXT
NEXT
CLOSE #1

ay = 0
FOR y = 1 TO ly * zoom STEP zoom
ay = ay + 1
ax = 0
FOR x = 1 TO lx * zoom STEP zoom
ax = ax + 1
LINE (x, y)-(x + zoom, y + zoom), col(ax, ay), BF
NEXT
NEXT

x = 1
y = 1
sx = 1
sy = 1


END SUB

SUB mouse
CALL INTERRUPTX(&H33, in, outr)
END SUB

SUB save
up$ = CHR$(0) + CHR$(72): down$ = CHR$(0) + CHR$(80): lft$ = CHR$(0) + CHR$(75)
rght$ = CHR$(0) + CHR$(77)
DIM prevy(16383)
DIM prevx(16383)
GET (0, y)-(x, y), prevy
GET (x, 0)-(x, y), prevx

DO
a$ = INKEY$
color2 = 11
LINE (x, y)-(x + zoom, y + zoom), color2, BF
'draws a straight line from the wall to the block so the user
'knows what he is saving
LINE (0, y)-(x, y), 9
LINE (x, 0)-(x, y), 9


SELECT CASE UCASE$(a$)
  'gets rid of lines and exits sub
  CASE "S"
  LINE (0, y)-(x, y), 0
  PUT (0, y), prevy
  LINE (x, 0)-(x, y), 0
  PUT (x, 0), prevx
  EXIT SUB

  'checks witch direction then clears the line
  'puts back what was there and moves the cursor
  CASE up$
  IF y >= 1 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sy = sy - 1
  y = y - (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE down$
  IF y <= 294 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sy = sy + 1
  y = y + (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE rght$
  IF x <= 314 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sx = sx + 1
  x = x + (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE lft$
  IF x >= 1 THEN
  LINE (0, y)-(x, y), 0
  LINE (x, 0)-(x, y), 0
  LINE (x, y)-(x + zoom, y + zoom), 0, BF
  PUT (0, y), prevy
  PUT (x, 0), prevx
  color1 = 0
  PUT (x, y), prev
  sx = sx - 1
  x = x - (zoom + 1)
  GET (0, y)-(x, y), prevy
  GET (x, 0)-(x, y), prevx
  GET (x, y)-(x + zoom, y + zoom), prev
  END IF


  CASE CHR$(9)
  savepic
END SELECT
LOOP

END SUB

SUB savepic
CLS
SCREEN 1
INPUT "Save name:", filename$
filename$ = filename$ + ".pic"
cx = sx
cy = sy
OPEN filename$ FOR OUTPUT AS #1
WRITE #1, cx, cy
FOR cy = 1 TO sy
FOR cx = 1 TO sx
WRITE #1, col(cx, cy)
NEXT
NEXT
CLOSE #1
CLS
PRINT filename$; " saved"
END
END SUB

[TheDarkJay]

Um, how do i do that on xp?

edit

does anyone actually know why the save sub in this won't work with FB