BBC BASIC for Windows
« Color mixer with Hexidecimal rr gg bb for 3D »

Welcome Guest. Please Login or Register.
Apr 5th, 2018, 10:00pm



ATTENTION MEMBERS: Conforums will be closing it doors and discontinuing its service on April 15, 2018.
Ad-Free has been deactivated. Outstanding Ad-Free credits will be reimbursed to respective payment methods.

If you require a dump of the post on your message board, please come to the support board and request it.


Thank you Conforums members.

BBC BASIC for Windows Resources
Online BBC BASIC for Windows documentation
BBC BASIC for Windows Beginners' Tutorial
BBC BASIC Home Page
BBC BASIC on Rosetta Code
BBC BASIC discussion group
BBC BASIC for Windows Programmers' Reference

« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: Color mixer with Hexidecimal rr gg bb for 3D  (Read 281 times)
michael
Senior Member
ImageImageImageImage


member is offline

Avatar




PM


Posts: 335
xx Color mixer with Hexidecimal rr gg bb for 3D
« Thread started on: Sep 3rd, 2017, 04:15am »

I dug up some old code and repurposed it for Vertex coloring.

So now you move the sliders to mix the color you want and then it will automatically create the Hexidecimal values for the rr gg bb values you need to color each triangle.

Now it is possible to get custom complex colors easy.

It could be more compact.
Code:
      ON ERROR END
      PROCgraphics(400,300)
      DIM cmd$(50)
      current$="":ln%=0:pln%=0
      butx%=0:buty%=0:buth%=0:butv%=0:sx%=0:sy%=0:sh%=0:sv%=0:cx%=0:cy%=0
      PROCcolor("b","000,000,000"):CLG
      PROCcolor("f","yellow")

      PROCpr(10,425,"Color Mixer with Hexidecimal for rr gg bb ","white")

      REPEAT
        s3$=FNcolormix(100,100)
        MOUSE mx%,my%,butt%
        IF mx%>0 AND mx%<501 AND my%>0 AND my%<501 AND butt%=4 THEN butx%=mx%/10:buty%=my%/10
        IF mx%>0 AND mx%<501 AND my%>0 AND my%<501 AND butt%=1 THEN buth%=mx%/10:butv%=my%/10
        IF butx%<1 THEN butx%=1
        IF buty%<1 THEN buty%=1
        IF buth%<1 THEN buth%=1
        IF butv%<1 THEN butv%=1
        WAIT 10
      UNTIL FALSE
      END

      REM COLORMIX object mixer
      DEFFNcolormix(x,y)
      PRIVATE rgb$,r%,g%,b%,switch%
      LOCAL h%,v%,click%
      MOUSE h%,v%,click%
      IF click%=4 THEN
        IF h%>x AND h%<x+50 AND v%>y AND v%<y+255 THEN r%=v%-y
        IF h%>x+49 AND h%<x+90 AND v%>y AND v%<y+255 THEN g%=v%-y
        IF h%>x+99 AND h%<x+140 AND v%>y AND v%<y+255 THEN b%=v%-y
      ENDIF
      IF switch%=0 OR click%=4 THEN
        PROCsbox(x-5,y-5,x+150,y+265,"255,255,255")
        PROCsbox(x,y+r%,x+40,y+r%+10,"200,000,000")
        PROCsbox(x+50,y+g%,x+90,y+g%+10,"000,200,000")
        PROCsbox(x+100,y+b%,x+140,y+b%+10,"000,000,200")
        switch%=1
        rgb$=FNnumstr(r%)+","+FNnumstr(g%)+","+FNnumstr(b%)
        PROCsbox(x-5,y+265,x+150,y+295,rgb$)
      ENDIF
      PROCpr(10,80,"rr "+STR$~(r%)+" gg "+STR$~(g%)+" bb "+STR$~(b%)+"","white")
      =rgb$
      REM  GRAPHICS(x,y)
      DEF PROCgraphics(x,y)
      VDU 23,22,x;y;8,15,16,1
      OFF
      VDU 5
      ENDPROC
      REM SBOX **********************
      DEF PROCsbox(x%,y%,w%,h%,c$)
      LOCAL ry%,sx%,sy%
      sx%=x%:sy%=y%
      IF x%>w% THEN x%=w%:w%=sx%
      IF y%>h% THEN y%=h%:h%=sy%
      ry%=y%
      PROCcolor("f",c$)
      REPEAT
        LINE x%,y%,w%,y%
        y%=y%+1
      UNTIL y%=h%
      y%=ry%
      IF c$<>"0" THEN PROCcolor("f","000,000,000") ELSE PROCcolor("f","white")
      LINE x%+2,y%+2,w%-2,y%+2
      LINE w%-2,y%+2,w%-2,h%-4
      LINE w%-2,h%-4,x%+2,h%-4
      LINE x%+2,h%-4,x%+2,y%+2
      PROCresetrgb
      ENDPROC
      REM RECT **********************
      DEFPROCrect(x%,y%,w%,h%)
      LOCAL sx%,sy%
      sx%=x%:sy%=y%
      IF x%>w% THEN x%=w%:w%=sx%
      IF y%>h% THEN y%=h%:h%=sy%
      LINE x%,y%,w%,y%
      LINE w%,y%,w%,h%
      LINE w%,h%,x%,h%
      LINE x%,h%,x%,y%
      ENDPROC
      REM pixel *******************
      REM restore default color palettes
      DEFPROCresetrgb
      COLOUR 0,0,0,0 :COLOUR 1,200,0,0 :COLOUR 2,000,200,000
      COLOUR 3,200,200,000:COLOUR 4,000,000,200:COLOUR 5,200,000,200
      COLOUR 6,000,200,200:COLOUR 7,200,200,200:COLOUR 8,056,056,056
      COLOUR 9,248,056,056:COLOUR 10,056,248,056:COLOUR 11,248,248,056
      COLOUR 12,056,056,248:COLOUR 13,248,056,248:COLOUR 14,056,248,248
      COLOUR 15,248,248,248
      ENDPROC
      DEF PROCcolor(fb$,rgb$)
      PRIVATE assemble$,br%,bg%,bb%
      IF rgb$="0" OR rgb$="black" THEN rgb$="000,000,000"
      IF rgb$="1" OR rgb$="red" THEN rgb$="200,000,000"
      IF rgb$="2" OR rgb$="green" THEN rgb$="000,200,000"
      IF rgb$="3" OR rgb$="yellow" THEN rgb$="200,200,000"
      IF rgb$="4" OR rgb$="blue" THEN rgb$="000,000,200"
      IF rgb$="5" OR rgb$="magenta" THEN rgb$="200,000,200"
      IF rgb$="6" OR rgb$="cyan" THEN rgb$="000,200,200"
      IF rgb$="7" OR rgb$="white" THEN rgb$="200,200,200"
      IF rgb$="8" OR rgb$="grey" THEN rgb$="056,056,056"
      IF rgb$="9" OR rgb$="light red" THEN rgb$="248,056,056"
      IF rgb$="10" OR rgb$="light green" THEN rgb$="056,248,056"
      IF rgb$="11" OR rgb$="light yellow" THEN rgb$="248,248,056"
      IF rgb$="12" OR rgb$="light blue" THEN rgb$="056,056,248"
      IF rgb$="13" OR rgb$="light magenta" THEN rgb$="248,056,248"
      IF rgb$="14" OR rgb$="light cyan" THEN rgb$="056,248,248"
      IF rgb$="15" OR rgb$="light white" THEN rgb$="248,248,248"
      assemble$=rgb$
      br%=VAL(MID$(assemble$,1,3)):bg%=VAL(MID$(assemble$,5,3)):bb%=VAL(MID$(assemble$,9,3))
      IF fb$="f" OR fb$="F" THEN COLOUR 0,br%,bg%,bb% : GCOL 0
      IF fb$="b" OR fb$="B" THEN COLOUR 1,br%,bg%,bb% : GCOL 128+1
      ENDPROC
      DEFFNnumstr(num)
      LOCAL cov$,l%
      cov$=STR$(num)
      l%=LEN(cov$)
      IF l%=1 THEN ret$="00"+cov$
      IF l%=2 THEN ret$="0"+cov$
      IF l%=3 THEN ret$=cov$
      =ret$
      DEFPROCpaint(x%,y%,co$)
      PROCcolor("b",FNrgb(x%,y%)):PROCcolor("f",co$)
      FILL x%,y%
      ENDPROC
      REM dotrgb ********************************
      DEFPROCdotrgb(x%,y%,r%,g%,b%)
      COLOUR 0,r%,g%,b% : GCOL 0
      MOVE x%,y%:DRAW x%,y%
      ENDPROC
      REM *****SPECIAL RGB tools (color extraction) has use with PROCdotrgb
      DEF PROCrgbret(x%,y%,RETURN r%,RETURN g%,RETURN b%)
      LOCAL rgb%
      rgb%=TINT(x%,y%)
      b%=INT(rgb%/(256*256))
      g%=INT((rgb%-b% *256*256)/256)
      r%=INT(rgb%-b%*256*256-g%*256)
      ENDPROC
      REM experimental
      DEFFNrgb(x%,y%)
      LOCAL r$,g$,b$,join$,r,g,b
      rgb%=TINT(x%,y%)
      b=INT(rgb%/(256*256))
      g=INT((rgb%-b *256*256)/256)
      r=INT(rgb%-b*256*256-g*256)
      r$=FNnumstr(r):g$=FNnumstr(g):b$=FNnumstr(b)
      join$=r$+","+g$+","+b$
      =join$
      REM  "INTERFACE" -library - for graphics text input and other tools
      REM X,Y,message,r,g,b
      DEF PROCpr(X,Y,msg$,c$)
      PRIVATE trackx,tracky,trackmsg$,trackc$
      LOCAL initialx%,fi%,reduction%,tx,ty
      IF trackx=X AND tracky=Y AND trackmsg$<>msg$ THEN PROCprsub(trackx,tracky,trackmsg$,"000,000,000")
      IF trackx<>X OR tracky<>Y OR trackmsg$<>msg$ OR trackc$<>c$ THEN
        initialx%=LEN(msg$)
        PROCcolor("f",c$)
        GCOL 0
        LET tx= X+initialx%+25
        LET ty= Y:reduction%=0
        reduction%=initialx%/2
        reduction%=reduction%*6
        IF initialx%<20 THEN reduction%=reduction%/2
        initialx%=initialx%*22-reduction%
        FOR fi%=12 TO 48
          LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
        NEXT
        COLOUR 0,0,0,0
        GCOL 0
        MOVE tx,ty
        PRINT msg$
        MOVE 0,0
      ENDIF
      trackx=X:tracky=Y:trackmsg$=msg$:trackc$=c$
      ENDPROC
      DEFPROCprsub(X,Y,msg$,c$)
      LOCAL initialx%,fi%,reduction%,tx,ty
      initialx%=LEN(msg$)
      PROCcolor("f",c$)
      GCOL 0
      LET tx= X+initialx%+25
      LET ty= Y:reduction%=0
      reduction%=initialx%/2
      reduction%=reduction%*6
      IF initialx%<20 THEN reduction%=reduction%/2
      initialx%=initialx%*22-reduction%
      FOR fi%=12 TO 48
        LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
      NEXT
      COLOUR 0,0,0,0
      GCOL 0
      MOVE tx,ty
      PRINT msg$
      MOVE 0,0
      ENDPROC
 
User IP Logged

I like making program generators and like reinventing the wheel
Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

| |

This forum powered for FREE by Conforums ©
Terms of Service | Privacy Policy | Conforums Support | Parental Controls